diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,68 @@ +# 1.1.0 + +* Breaking Change - I removed the use of `String` and replaced it with either `Text` or `JSString` + (from the `Data.JSString` module in `ghcjs-base`). If a value was just going to be passed straight into + react, I made it a JSString and if the value was intended to be manipulated in Haskell I used Text. + The main changes are: + + * `elemText` used to (confusingly) take a `String`. Now there are three functions: `elemString`, + `elemText`, and `elemJSString` that take a `String`, `Text`, and `JSString` value respectively. + + * The type of `$=` now uses JSString. `$=` is intended only to avoid ambiguity when using + overloaded strings and string constants and `JSString` has an `IsString` instance. + + * There is a new property creator `&=` which instead of converting to Aeson and then to a javascript + value like `@=` does, `&=` uses the `ToJSVal` class from `GHCJS.Foreign.Marshal` to convert values + directly to javascript. + + * Several functions had their type changed to instead of taking a String as a param take a Text or + JSString as a parameter + + Despite being quite a large change, it didn't take much effort for me to convert my application to this + new API. You can see the conversion of the todo example application here: + https://bitbucket.org/wuzzeb/react-flux/commits/a630da5f9032745ab92da6e3d9f9038915b9b319 + The main things that required changing are: + + * Converting between `String` and `JSString` is done via `pack` and `unpack` in `Data.JSString`. + Converting between `Text` and `JSString` is done via `textToJSString` and `textFromJSString` + in the `Data.JSString.Text` module. In fact, this conversion needed to happen in only a + few places for me because for the most part the `IsString` instance and `OverloadedStrings` + extension properly converted the string literals to the proper type. A few places I needed to + use `<>` from `Data.Monoid` to concatenate `JSString`s. + + * A few places I was accidentally using `$=` for non-literal strings. Switching these to `&=` + was enough, since `&=` is polymorphic over the type of the property value. + + * Most places using `elemText` had an error, but here it was straightforward to switch to + either `elemString` or keep `elemText` and use `Text` values inside my store. + +* React-flux has used the shouldComponentUpdate lifetime method to prevent re-rendering in some cases, + but it was finicky and sometimes wouldn't work (not a correctness bug, just a missed performance + improvement). I now better understand when it works and does not work, and edited the documentation + to explain this and what you can do in your own code (primarily add bang patterns to force thunks). + The new documentation is at the end of the main module page. + +* The shouldComponentUpdate lifetime method now knows about view props which are tuples of size two or + three, and will be able to skip re-rendering as long as each component of the tuple is unchanged + (and is not a thunk). + +* `React.Flux.Addons.Intl` now uses a new type `IntlProperty` defined in the module instead of using + the pair type from aeson. This allows passing arbitrary JSVals to i18n functions instead of just + aeson values. This causes API breakage in `formattedNumberProp`, `formattedDateProp`, `pluralProp`, + `messageProp`, and `messageProp'`. + +* Ability to export react views to JavaScript. `callbackViewWithProps` inside `React.Flux.PropertiesAndEvents` + allows you to create a javascript function which returns a renderable and then pass that JavaScript + function to a foreign JavaScript class. This is useful for example for fixed-data-table and ReactNative's + ListView among others. Secondly, `exportViewToJavaScript` from `React.Flux` allows just exporting + a view to a JavaScript function, which is useful to embed a Haskell application into a larger JavaScript + React application. + +* Add a `style` combinator to easily write inline styles on elements. + +* Add `viewWithIKey` and `viewWithSKey` for views with integer and string keys. The old `viewWithKey` + was akward to use when OverloadedStrings was enabled. + # 1.0.7 * Fix the build when building with GHC instead of GHCJS (an import was incorrectly protected by CPP) diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ js-build/install-root: $(INSTALL_ROOT) mkdir -p js-build - ln -s $(INSTALL_ROOT) js-build/install-root + ln -sf $(INSTALL_ROOT) js-build/install-root js-build/todo.min.js: js-build/todo.js closure --compilation_level=ADVANCED_OPTIMIZATIONS js-build/todo.js > js-build/todo.min.js diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,29 +12,27 @@ I use stack to build my frontend which uses react-flux. I set up stack and ghcjs using [these -instructions](http://docs.haskellstack.org/en/stable/ghcjs.html). Note that -react-flux requires GHCJS master (a.k.a. improved base). At the moment I want -to use GHC 7.10.3 and no ghcjs snapshot uses lts-4.1 and GHC 7.10.3, so I am -building ghcjs manually. So what I do is [install ghcjs from -git](https://github.com/ghcjs/ghcjs) using the following. (Once the ghcjs -snapshots have caught up I will transition to using them and have stack install -ghcjs instead of installing ghcjs manually.) - -~~~ -$ git clone https://github.com/ghcjs/ghcjs.git -$ cabal install ./ghcjs -$ ghcjs-boot --dev -~~~ - -After this, in my application which depends on react-flux, I use the following `stack.yaml`: +instructions](http://docs.haskellstack.org/en/stable/ghcjs/). Note that +react-flux requires GHCJS master (a.k.a. improved base). I keep updated with +the latest version of GHCJS and lts. As I write this, I use the following `stack.yaml`, +but as new LTS versions or new GHCJS versions come out I keep updating to them (and +probably forget to update this README :) ~~~ -resolver: lts-4.1 -compiler: ghcjs-0.2.0_ghc-7.10.3 +resolver: lts-6.1 packages: - . extra-deps: - - react-flux-1.0.3 + - react-flux-(version) + +compiler: ghcjs-0.2.0.20160414_ghc-7.10.3 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.0.20160414_ghc-7.10.3: + url: https://s3.amazonaws.com/ghcjs/ghcjs-0.2.0.20160414_ghc-7.10.3.tar.gz + sha1: 6d6f307503be9e94e0c96ef1308c7cf224d06be3 ~~~ @@ -62,23 +60,18 @@ haskell application using [hspec-webdriver](https://hackage.haskell.org/package/hspec-webdriver). This must be built using GHC (not GHCJS), so there is a separate `stack.yaml` file -in the `test/spec` directory. In summary, run the following commands: +in the `test/spec` directory. Also, `react-intl` must be installed in the test client +directory. In summary, run the following commands: ~~~ {.bash} -stack build -make +cd test/client +npm install react-intl cd test/spec stack build ~~~ Next, install [selenium-server-standalone](http://www.seleniumhq.org/download/) (also from -[npm](https://www.npmjs.com/package/selenium-server-standalone-jar)). Also, at the moment, the -release candiate of the react-intl library must be installed from npm. - -~~~ -cd test/client -npm install react-intl@v2.0.0-rc-1 -~~~ +[npm](https://www.npmjs.com/package/selenium-server-standalone-jar)). 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 diff --git a/example/purecss-side-menu/PageViews.hs b/example/purecss-side-menu/PageViews.hs --- a/example/purecss-side-menu/PageViews.hs +++ b/example/purecss-side-menu/PageViews.hs @@ -17,7 +17,7 @@ clbutton_ "pure-button" (changePageTo Page2) "Change to page 2" "Also, try reducing the browser width to see the responsive menu." p_ $ do - "You must load this file from a server. If you did not, no page changes will work. Use for example " + "You must load this file from a server. If you did not, page changes might not work depending on your browser security settings (some features don't always work for file URLs). Use for example " code_ "python3 -m http.server 8000" " or " code_ "python2 -m SimpleHTTPServer 8000" diff --git a/example/purecss-side-menu/index.html b/example/purecss-side-menu/index.html --- a/example/purecss-side-menu/index.html +++ b/example/purecss-side-menu/index.html @@ -9,8 +9,8 @@
- - + + diff --git a/example/routing/EventTest.hs b/example/routing/EventTest.hs --- a/example/routing/EventTest.hs +++ b/example/routing/EventTest.hs @@ -20,6 +20,10 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) +#ifdef __GHCJS__ +import Data.JSString (JSString) +#endif + data ETState = ETState { etActions :: [ETAction] , etText :: !T.Text @@ -69,13 +73,13 @@ view :: ReactView ETState view = defineView "event-tests" $ \(ETState actions text bool) -> section_ $ do - let textVal = "value" $= text + let textVal = "value" &= text div_ ["className" $= "et-actions"] $ do a_ [onClick $ \_ _ -> dispatchEventTest ClearActionsA] $ elemText "Clear event history" pre_ $ - elemText $ unlines $ map show actions + elemString $ unlines $ map show actions h2_ $ elemText "Testing keyboard events" p_ $ elemText "Type to test onKeyUp/onKeyDown" @@ -187,13 +191,13 @@ #ifdef __GHCJS__ -targetInt :: Event -> String -> Int +targetInt :: Event -> JSString -> Int targetInt = target -targetText :: Event -> String -> T.Text +targetText :: Event -> JSString -> T.Text targetText = target -targetBool :: Event -> String -> Bool +targetBool :: Event -> JSString -> Bool targetBool = target #else diff --git a/example/routing/Main.hs b/example/routing/Main.hs --- a/example/routing/Main.hs +++ b/example/routing/Main.hs @@ -1,5 +1,6 @@ -- | +{-# LANGUAGE OverloadedStrings #-} module Main where import React.Flux @@ -9,6 +10,7 @@ import Router import qualified TabbedApps as TabbedApps import Types +import qualified Data.Text as T main :: IO () main = do @@ -33,15 +35,15 @@ TabbedApps.Tab (appName a) (\pr -> view v pr mempty) (appRouter a)) apps appViews -clockApp :: String -> App TabbedApps.ParentRouter +clockApp :: T.Text -> App TabbedApps.ParentRouter clockApp name = App name Clock.store (\st _ -> Clock.view_ st) Clock.ClockInit Nothing -etApp :: String -> App TabbedApps.ParentRouter +etApp :: T.Text -> App TabbedApps.ParentRouter etApp name = App name rst (\st _ -> EventTest.view_ st) EventTest.ETInit Nothing where rst = EventTest.store -tabApp :: String -> [TabbedApps.Tab] -> App TabbedApps.ParentRouter +tabApp :: T.Text -> [TabbedApps.Tab] -> App TabbedApps.ParentRouter tabApp name tabs = let rst = TabbedApps.newStore tabs in diff --git a/example/routing/TabbedApps.hs b/example/routing/TabbedApps.hs --- a/example/routing/TabbedApps.hs +++ b/example/routing/TabbedApps.hs @@ -112,7 +112,7 @@ span_ ["style" @= A.object ["color" A..= ("#eee"::String)] | cur == aidx] $ if cur == aidx then elemText aname - else a_ ["href" $= actionRoute prouter (SwitchApp aidx Nothing)] $ elemText aname + else a_ ["href" &= actionRoute prouter (SwitchApp aidx Nothing)] $ elemText aname tabItem_ :: ((ParentRouter, Int), (Int, AppName)) -> ReactElementM eventHandler () tabItem_ tab = diff --git a/example/routing/Types.hs b/example/routing/Types.hs --- a/example/routing/Types.hs +++ b/example/routing/Types.hs @@ -14,8 +14,9 @@ import qualified Data.Text as T import Data.Typeable (Typeable) +import qualified Data.JSString.Text as JSS -type AppName = String +type AppName = T.Text type AppView = ReactElementM ViewEventHandler type AppRouter = [T.Text] -> IO () @@ -30,6 +31,6 @@ initApp :: Typeable props => App props -> IO (ReactView props) initApp App{..} = do - let view' = defineControllerView appName appState (\st props -> appView st props) + let view' = defineControllerView (JSS.textToJSString appName) appState (\st props -> appView st props) alterStore appState appInitAction return view' diff --git a/example/todo/TodoComponents.hs b/example/todo/TodoComponents.hs --- a/example/todo/TodoComponents.hs +++ b/example/todo/TodoComponents.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} -- | The division between a view and a component is arbitrary, but for me components are pieces that -- are re-used many times for different purposes. In the TODO app, there is one component for the @@ -7,15 +7,17 @@ import Data.Typeable (Typeable) import React.Flux +import Data.JSString (JSString) +import qualified Data.Text as T -- | The properties for the text input component. Note how we can pass anything, including -- functions, as the properties; the only requirement is an instance of Typeable. data TextInputArgs = TextInputArgs { - tiaId :: Maybe String - , tiaClass :: String - , tiaPlaceholder :: String - , tiaOnSave :: String -> [SomeStoreAction] - , tiaValue :: Maybe String + tiaId :: Maybe JSString + , tiaClass :: JSString + , tiaPlaceholder :: JSString + , tiaOnSave :: T.Text -> [SomeStoreAction] + , tiaValue :: Maybe T.Text } deriving (Typeable) -- | The text input stateful view. The state is the text that has been typed into the textbox @@ -24,27 +26,27 @@ todoTextInput :: ReactView TextInputArgs todoTextInput = defineStatefulView "todo text input" "" $ \curText args -> input_ $ - maybe [] (\i -> ["id" @= i]) (tiaId args) + maybe [] (\i -> ["id" &= i]) (tiaId args) ++ - [ "className" @= tiaClass args - , "placeholder" @= tiaPlaceholder args - , "value" @= curText -- using value here creates a controlled component: https://facebook.github.io/react/docs/forms.html - , "autoFocus" @= True + [ "className" &= tiaClass args + , "placeholder" &= tiaPlaceholder args + , "value" &= curText -- using value here creates a controlled component: https://facebook.github.io/react/docs/forms.html + , "autoFocus" &= True -- Update the current state with the current text in the textbox, sending no actions , onChange $ \evt _ -> ([], Just $ target evt "value") -- Produce the save action and reset the current state to the empty string , onBlur $ \_ _ curState -> - if not (null curState) + if not (T.null curState) then (tiaOnSave args curState, Just "") else ([], Nothing) , onKeyDown $ \_ evt curState -> - if keyCode evt == 13 && not (null curState) -- 13 is enter + if keyCode evt == 13 && not (T.null curState) -- 13 is enter then (tiaOnSave args curState, Just "") else ([], Nothing) ] -- | A combinator suitible for use inside rendering functions. todoTextInput_ :: TextInputArgs -> ReactElementM eventHandler () -todoTextInput_ args = view todoTextInput args mempty +todoTextInput_ !args = view todoTextInput args mempty diff --git a/example/todo/TodoStore.hs b/example/todo/TodoStore.hs --- a/example/todo/TodoStore.hs +++ b/example/todo/TodoStore.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE TypeFamilies, DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE TypeFamilies, DeriveGeneric, DeriveAnyClass, OverloadedStrings #-} module TodoStore where import React.Flux import Control.DeepSeq import GHC.Generics (Generic) import Data.Typeable (Typeable) +import qualified Data.Text as T data Todo = Todo { - todoText :: String + todoText :: T.Text , todoComplete :: Bool , todoIsEditing :: Bool } deriving (Show, Typeable) @@ -16,10 +17,10 @@ todoList :: [(Int, Todo)] } deriving (Show, Typeable) -data TodoAction = TodoCreate String +data TodoAction = TodoCreate T.Text | TodoDelete Int | TodoEdit Int - | UpdateText Int String + | UpdateText Int T.Text | ToggleAllComplete | TodoSetComplete Int Bool | ClearCompletedTodos diff --git a/example/todo/TodoViews.hs b/example/todo/TodoViews.hs --- a/example/todo/TodoViews.hs +++ b/example/todo/TodoViews.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} -- | The views for the TODO app module TodoViews where @@ -82,7 +82,7 @@ -- | A combinator for a todo item to use inside rendering functions todoItem_ :: (Int, Todo) -> ReactElementM eventHandler () -todoItem_ todo = viewWithKey todoItem (fst todo) todo mempty +todoItem_ !todo = viewWithIKey todoItem (fst todo) todo mempty -- | A view for the footer, taking the entire state as the properties. This could alternatively -- been modeled as a controller-view, attaching directly to the store. @@ -100,8 +100,8 @@ button_ [ "id" $= "clear-completed" , onClick $ \_ _ -> dispatchTodo ClearCompletedTodos ] $ - elemText $ "Clear completed (" ++ show completed ++ ")" + elemString $ "Clear completed (" ++ show completed ++ ")" -- | A render combinator for the footer todoFooter_ :: TodoState -> ReactElementM eventHandler () -todoFooter_ s = view todoFooter s mempty +todoFooter_ !s = view todoFooter s mempty diff --git a/example/todo/run-in-node.js b/example/todo/run-in-node.js --- a/example/todo/run-in-node.js +++ b/example/todo/run-in-node.js @@ -1,2 +1,3 @@ React = require("react"); +ReactDOMServer = require("react-dom/server"); require("../../js-build/install-root/bin/todo-node.jsexe/all.js"); diff --git a/example/todo/todo-dev.html b/example/todo/todo-dev.html --- a/example/todo/todo-dev.html +++ b/example/todo/todo-dev.html @@ -7,8 +7,8 @@
- - + + diff --git a/example/todo/todo.html b/example/todo/todo.html --- a/example/todo/todo.html +++ b/example/todo/todo.html @@ -7,8 +7,8 @@
- - + + diff --git a/jsbits/callback.js b/jsbits/callback.js --- a/jsbits/callback.js +++ b/jsbits/callback.js @@ -7,3 +7,15 @@ f(args); }; } + +function hsreact$wrap_callback_returning_element(f) { + return function() { + var args = new Array(arguments.length); + for (var i = 0; i < arguments.length; i++) { + args[i] = arguments[i]; + } + var ret = {}; + f(ret, args); + return ret.elem; + }; +} diff --git a/jsbits/native.js b/jsbits/native.js new file mode 100644 --- /dev/null +++ b/jsbits/native.js @@ -0,0 +1,3 @@ +//Tests for ReactNative +var hsreact$divLikeElement = (typeof window === "object" && window['navigator']['product'] === "ReactNative") ? window["View"] : "div"; +var hsreact$textWrapper = (typeof window === "object" && window['navigator']['product'] === "ReactNative") ? window["Text"] : "span"; diff --git a/jsbits/views.js b/jsbits/views.js --- a/jsbits/views.js +++ b/jsbits/views.js @@ -32,13 +32,55 @@ }, _currentCallbacks: [] }; + + //Checks if the javascript representations of two haskell values are the same. + //This can't check equality but just checks if the javascript object has not been + //changed. We have special support for tuples of size 2 and 3, where we do check if the individual components of + //the tuple are equal. + var areValuesSame = function(obj1, obj2) { + if (obj1 == obj2) { //use two equal signs to test if the objects are the same + return true; + + } else { + + //check tuples of size two and 3. + // + //Tuples of size 2 are stored as + // { d1: first value + // , d2: second value + // , f: constructor function + // } + // + //Tuples of size 3 are stored as + // { d1: first value + // , d2: { d1: second value + // , d2: third value + // } + // , f: constructor function + // } + var obj1_f = (obj1['f'] || {})['name']; + var obj2_f = (obj2['f'] || {})['name']; + + if (obj1_f === "h$ghczmprimZCGHCziTupleziZLz2cUZR_con_e" && obj1_f === obj2_f) { + //pair + return obj1['d1'] == obj2['d1'] && obj1['d2'] == obj2['d2']; //use two equal signs to test if the objects are the same + + } else if (obj1_f === "h$ghczmprimZCGHCziTupleziZLz2cUz2cUZR_con_e" && obj1_f === obj2_f) { + var obj1_d2 = obj1['d2'] || {}; + var obj2_d2 = obj2['d2'] || {}; + return obj1['d1'] == obj2['d1'] && obj1_d2['d1'] == obj2_d2['d1'] && obj1_d2['d2'] == obj2_d2['d2']; + } else { + return false; + } + } + }; if (checkState) { cl['shouldComponentUpdate'] = function(newProps, newState) { - return this['props'].hs.root != newProps.hs.root || this['state'].hs.root != newState.hs.root; + return !areValuesSame(this['props'].hs.root, newProps.hs.root) || !areValuesSame(this['state'].hs.root, newState.hs.root); }; } else { cl['shouldComponentUpdate'] = function(newProps, newState) { - return this['props'].hs.root != newProps.hs.root; + return !areValuesSame(this['props'].hs.root, newProps.hs.root); }; } diff --git a/react-flux.cabal b/react-flux.cabal --- a/react-flux.cabal +++ b/react-flux.cabal @@ -1,5 +1,5 @@ name: react-flux -version: 1.0.7 +version: 1.1.0 synopsis: A binding to React based on the Flux application architecture for GHCJS category: Web homepage: https://bitbucket.org/wuzzeb/react-flux @@ -53,6 +53,7 @@ jsbits/export.js jsbits/callback.js jsbits/ajax.js + jsbits/native.js exposed-modules: React.Flux React.Flux.DOM @@ -106,6 +107,9 @@ build-depends: base , react-flux , deepseq + , text + if impl(ghcjs) + build-depends: ghcjs-base executable todo-node if !flag(example) @@ -119,6 +123,8 @@ , react-flux , deepseq , text + if impl(ghcjs) + build-depends: ghcjs-base executable purecss-side-menu if !flag(example) @@ -135,24 +141,7 @@ if impl(ghcjs) build-depends: ghcjs-base -executable test-client-13 - 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: TestClient13.hs - build-depends: base - , react-flux - , time - , deepseq - if impl(ghcjs) - build-depends: ghcjs-base - -executable test-client-14 +executable test-client if !flag(test-client) Buildable: False ghc-options: -Wall @@ -160,11 +149,11 @@ default-language: Haskell2010 hs-source-dirs: test/client - other-modules: TestClient - main-is: TestClient14.hs + main-is: TestClient.hs build-depends: base , react-flux , time + , text , deepseq , aeson if impl(ghcjs) diff --git a/src/React/Flux.hs b/src/React/Flux.hs --- a/src/React/Flux.hs +++ b/src/React/Flux.hs @@ -30,14 +30,20 @@ -- >})(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 +-- running in node (not the browser). To execute with node, you need to get @global.React@ and +-- @global.ReactDOMServer@ 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"); +-- >ReactDOMServer = require("react-dom/server"); -- >require("../../js-build/install-root/bin/todo-node.jsexe/all.js"); -- +-- __React Native__: This module also works with +-- to create a standalone native applications. When combined with , +-- you can even create standalone desktop applications. The workflow is to use 'reactRender' the +-- same as web deployment but use the resulting JavaScript file in react-native and/or electron. +-- . +-- -- __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, @@ -52,6 +58,7 @@ -- The file -- in the source code contains a hspec-webdriver test for the TODO example application. +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- ArgumentsToProps is exported twice, once by React.Flux.PropertiesAndEvents and once here module React.Flux ( -- * Dispatcher -- $dispatcher @@ -76,11 +83,13 @@ -- * Elements , ReactElement , ReactElementM(..) + , elemString , elemText + , elemJSString , elemShow , view - , viewWithKey - , ReactViewKey + , viewWithSKey + , viewWithIKey , childrenPassedToView , foreignClass , module React.Flux.DOM @@ -90,9 +99,16 @@ -- * Main , reactRender , reactRenderToString + , exportViewToJavaScript + , ArgumentsToProps + , ReturnProps(..) -- * Performance -- $performance + + -- * Depracated + , viewWithKey + , ReactViewKey ) where import Data.Typeable (Typeable) @@ -106,7 +122,7 @@ import React.Flux.Store #ifdef __GHCJS__ -import GHCJS.Types (JSString, JSVal, nullRef) +import GHCJS.Types (JSVal, nullRef) import GHCJS.Marshal (fromJSVal) #endif @@ -138,8 +154,8 @@ #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. +-- | Render your React application to a string using either @ReactDOMServer.renderToString@ if the first +-- argument is false or @ReactDOMServer.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 @@ -159,11 +175,11 @@ maybe (error "Unable to convert string return to Text") return mtxt foreign import javascript unsafe - "(typeof ReactDOM === 'object' ? ReactDOM : React)['renderToString']($1)" + "(typeof ReactDOMServer === 'object' ? ReactDOMServer : (typeof ReactDOM === 'object' ? ReactDOM : React))['renderToString']($1)" js_ReactRenderToString :: ReactElementRef -> IO JSVal foreign import javascript unsafe - "(typeof ReactDOM === 'object' ? ReactDOM : React)['renderToStaticMarkup']($1)" + "(typeof ReactDOMServer === 'object' ? ReactDOMServer : (typeof ReactDOM === 'object' ? ReactDOM : React))['renderToStaticMarkup']($1)" js_ReactRenderStaticMarkup :: ReactElementRef -> IO JSVal #else @@ -178,6 +194,8 @@ -- and -- registered on the document. -- +-- __Reconciliation__ +-- -- To support fast reconciliation, React uses key properties (set by 'viewWithKey') and a -- @shouldComponentUpdate@ lifetime class method. The React documentation on -- talks @@ -185,24 +203,104 @@ -- implement a @shouldComponentUpdate@ method which compares if the javascript object representing -- the Haskell values for the @props@, @state@, and/or @storeData@ have changed. Thus if you do not -- modify a Haskell value that is used for the @props@ or @state@ or @storeData@, React will skip --- re-rendering that view instance. Care should be taken in the 'transform' function to not edit or --- recreate any values that are used as @props@. For example, instead of something like +-- re-rendering that view instance. Note that we are not checking equality, just if the javascript +-- object representing a Haskell object has changed, with some special support for pairs and tuples +-- of size three. -- --- >[ (idx, todo) | (idx, todo) <- todos, idx /= deleteIdx ] +-- There is subtle issue: this check only works if the props are not a thunk but are an actual data +-- constructor. Consider the following -- --- you should prefer +-- >data MyStoreData = MyStoreData { +-- > myA :: !A +-- > , myB :: !B +-- > , myC :: !C +-- > , myD :: !D +-- >} deriving (Show, Typeable) +-- > +-- >myAview :: ReactView A +-- >myAview = defineView .... +-- > +-- >myStoreView :: ReactView () +-- >myStoreView = defineControllerView "my store" myStore $ \myData () -> +-- > div_ $ view myAview (myA myData) mempty +-- > div_ .... -- --- >filter ((/=deleteIdx) . fst) todos --- --- After either of these transforms, the list of todos has changed so @mainSection@ will be re-rendered by --- React. @mainSection@ calls @todoItem@ with the tuple @(idx,todo)@ as the props. In the latter --- transform snippet above, the tuple value for the entries is kept unchanged, so the --- @shouldComponentUpdate@ function for @todoItem@ will return false and React will not re-render --- each todo item. If instead the tuple had been re-created as in the first snippet, the underlying --- javascript object will change even though the value is equal. The @shouldComponentUpdate@ --- function for @todoItem@ will then return true and React will re-render every todo item. Thus the --- latter snippet is preferred. In summary, if you are careful to only update the part of the store --- data that changed, React will only re-render those part of the page. +-- In @myStoreView@, note that @myA myData@ is passed as the props to @myAview@. So consider the +-- situtation when say an action changes @C@ but leaves @A@ unchanged. We would like for the +-- rendering of @myAview@ to be skipped, but unfortunately it will be re-rendered. The reason is +-- that the props passed to @myAview@ is an unevaluated thunk @myA myData@. Sure, the @A@ +-- constructor has not changed and if the thunk is forced it will return this unchanged @A@ data +-- constructor, but the @shouldComponentUpdate@ test does not do any computation or evaluation, it +-- just checks if the passed in javascript object is the same as it was the last time the view was +-- rendered. We can fix this by forcing the thunk before passing it to 'view', which I do via bang +-- patterns. Instead of ever calling 'view' directly from a rendering function, for each +-- 'ReactView' I create a combinator as follows: +-- +-- >myAview_ :: A -> ReactElementM handler () +-- >myAview_ !a = view myAview a mempty +-- > +-- >myStoreView :: ReactView () +-- >myStoreView = defineControllerView "my store" myStore $ \myData () -> +-- > div_ $ myAview_ (myA myData) +-- > div_ .... +-- +-- Note the bang pattern on the @a@ parameter to @myAview_@. What now happens is that the bang pattern +-- forces the thunk @myA myData@ to turn into the @A@ data constructor. If an action does not edit the @A@ portion +-- of the store data, this will still be represented by the same javascript object as before and +-- React will not re-render the @myAview@. +-- +-- Now consider another situtation where you would like a view that takes A and B. +-- +-- >myAandBview :: ReactView (A, B) +-- >myAandBview = defineView .... +-- > +-- >myAandBview_ :: A -> B -> ReactElementM handler () +-- >myAandBview_ !a !b = view myAandBview (a, b) mempty +-- > +-- >myStoreView :: ReactView () +-- >myStoreView = defineControllerView "my store" myStore $ \myData () -> +-- > div_ $ myAview_ (myA myData) +-- > div_ $ myAandBview_ (myA myData) (myB myData) +-- > div_ .... +-- +-- Again, if you have an action that just changes @C@ you would like @myAandBview@ to not be +-- re-rendered. With the simple javascript object check, it would be re-rendered because the props +-- are a tuple and the Haskell value (and thus javascript object) for the tuple is being recreated each +-- time @myStoreView@ is rendered. To overcome this obstacle, @react-flux@ contains special code to check pairs +-- and tuples of size three. If the props are a pair or a tuple of size three, the components of +-- the tuple will be compared to see if they are the same javascript object. Thus similar to the +-- above we need to make sure each component of the tuple is not a thunk but a data constructor, +-- which happens via the bang patterns in @myAandBview_@. The end result is that if an action just +-- changes @C@ or @D@ and leaves @A@ and @B@ unchanged, the above code will cause React to not +-- re-render @myAandBview@ because the two components of the pair are forced and are still the same +-- unchanged data value/javascript object. You can see this in action inside the test suite if you +-- would like an example. +-- +-- So far we have been focusing on making sure the new props are not a thunk by forcing it before +-- passing it into 'view'. But we also need to make sure the initial props are not a thunk. This +-- is not quite as bad since the check will only fail the next time a re-render occurs and after +-- that everything will be OK so we will still mostly skip re-rendering, but is still a small +-- annoyance. There are several ways to fix this, but the easiest is to add bang patterns to the +-- definition of @MyStoreData@. If you scroll up you can see that each member of @MyStoreData@ has +-- a bang pattern. Thus when an action does change @A@, whatever a new value is set into @myA@, it +-- will not be a thunk but an actual data constructor. Then the initial props passed into the view +-- will not be a thunk. +-- +-- In summary, you should follow these rules: +-- +-- 1. Use bang patterns on each member in your store data. In fact, once GHC 8 is released, I +-- plan on turning on the new @StrictData@ extension and then all these bang patterns can be +-- dropped. +-- +-- 2. Try and keep your view parameters as part of the store that will be unchanged by some +-- actions. Use tuples of size two or three to combine multiple parts of the store data or even +-- data from multiple stores. (Tuples of larger size could be supported without much effort if +-- required.) +-- +-- 3. For each view, make a combinator with a underscore suffix which uses bang patterns to force +-- the props before passing it to the 'view' function. +-- +-- __Events__ -- -- For events, React registers only global event handlers and also keeps event objects (the object -- passed to the handlers) in a pool and re-uses them for successive events. We want to parse this diff --git a/src/React/Flux/Addons/Bootstrap.hs b/src/React/Flux/Addons/Bootstrap.hs --- a/src/React/Flux/Addons/Bootstrap.hs +++ b/src/React/Flux/Addons/Bootstrap.hs @@ -1,6 +1,12 @@ -- | Bindings to . To use this -- binding, include the browser-global version of @react-bootstrap.js@ so that @window.ReactBootstrap@ -- is defined. You can then use 'bootstrap_' inside your rendering functions. +-- +-- Note: I initially wrote these bindings when I was first starting React, but after some experience +-- I think that bootstrap and react just do not fit together and I no longer use bootstrap and react +-- together. While I am leaving this here for backwards compatibility, I suggest you use a different +-- library. I am currently using and accessing the +-- components using @foreign_@. module React.Flux.Addons.Bootstrap ( bootstrap_ ) where diff --git a/src/React/Flux/Addons/Intl.hs b/src/React/Flux/Addons/Intl.hs --- a/src/React/Flux/Addons/Intl.hs +++ b/src/React/Flux/Addons/Intl.hs @@ -1,13 +1,7 @@ --- | Bindings to the 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 as a release candidate --- (I am currently using v2.0.0-rc-1). For temporary documentation, --- see . Because this is a binding to a --- release candidate, 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. +-- | Bindings to the library version 2, 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. -- -- 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 @@ -91,6 +85,10 @@ intlProvider_ -- * Formatting + , IntlProperty + , iprop + , dayProp + , timeProp -- ** Numbers , int_ @@ -125,6 +123,8 @@ , messageProp' , htmlMsg , htmlMsg' + , formattedMessage_ + , formattedHtmlMessage_ -- * Translation , Message(..) @@ -136,7 +136,6 @@ import Control.Monad (when, forM_) import Data.Aeson (Object, Value(Object), object, (.=)) -import Data.Aeson.Types (Pair) import Data.Char (ord, isPrint) import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe) @@ -146,7 +145,7 @@ import Language.Haskell.TH (runIO, Q, Loc, location, ExpQ) import Language.Haskell.TH.Syntax (liftString, qGetQ, qPutQ, reportWarning, Dec) import React.Flux -import React.Flux.Internal (PropertyOrHandler(PropertyFromContext)) +import React.Flux.Internal (PropertyOrHandler(PropertyFromContext), toJSString) import System.IO (withFile, IOMode(..)) import qualified Data.Aeson as Aeson import qualified Data.ByteString as B @@ -157,9 +156,9 @@ #ifdef __GHCJS__ -import GHCJS.Types (JSVal, JSString) +import GHCJS.Types (JSString, JSVal) import GHCJS.Marshal (ToJSVal(..)) -import qualified Data.JSString as JSS +import qualified JavaScript.Object as JSO foreign import javascript unsafe "$r = ReactIntl['IntlProvider']" @@ -194,8 +193,8 @@ js_mkDate :: Int -> Int -> Int -> JSVal -- | Convert a day to a javascript Date -dayToRef :: Day -> JSVal -dayToRef day = js_mkDate (fromIntegral y) m d +dayToJSVal :: Day -> JSVal +dayToJSVal day = js_mkDate (fromIntegral y) m d where (y, m, d) = toGregorian day @@ -204,31 +203,17 @@ js_mkDateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> JSVal -- | Convert a UTCTime to a javascript date object. -timeToRef :: UTCTime -> JSVal -timeToRef (UTCTime uday time) = js_mkDateTime (fromIntegral year) month day hour minute sec micro +timeToJSVal :: UTCTime -> JSVal +timeToJSVal (UTCTime uday time) = js_mkDateTime (fromIntegral year) month day hour minute sec milli where (year, month, day) = toGregorian uday TimeOfDay hour minute pSec = timeToTimeOfDay time (sec, fracSec) = properFraction pSec - micro = round $ fracSec * 1000000 - + milli = round $ fracSec * 1000 -- milli is 10^3 foreign import javascript unsafe "$1['intl'][$2]($3, $4)" - js_callContextAPI :: JSVal -> JSString -> JSVal -> JSVal -> IO JSVal - - -data ContextApiCall a = ContextApiCall String a [Pair] JSVal - -instance ToJSVal a => ToJSVal (ContextApiCall a) where - toJSVal (ContextApiCall name a b ctx) = do - aRef <- toJSVal a - bRef <- toJSVal $ object b - js_callContextAPI ctx (JSS.pack name) aRef bRef - -formatCtx :: ToJSVal a => String -> String -> a -> [Pair] -> PropertyOrHandler handler -formatCtx name func val options = PropertyFromContext name $ ContextApiCall func val options - + js_callContextAPI :: JSVal -> JSString -> JSVal -> JSO.Object -> IO JSVal #else type JSVal = () @@ -254,21 +239,53 @@ js_formatHtmlMsg :: JSVal js_formatHtmlMsg = () -dayToRef :: Day -> JSVal -dayToRef _ = () +dayToJSVal :: Day -> JSVal +dayToJSVal _ = () -timeToRef :: UTCTime -> JSVal -timeToRef _ = () +timeToJSVal :: UTCTime -> JSVal +timeToJSVal _ = () class ToJSVal a +instance ToJSVal JSVal +type JSString = String +#endif -formatCtx :: String -> String -> a -> [Pair] -> PropertyOrHandler handler -formatCtx name _ _ _ = PropertyFromContext name $ \() -> () +data IntlProperty = forall ref. ToJSVal ref => IntlProperty JSString ref + +iprop :: ToJSVal v => JSString -> v -> IntlProperty +iprop = IntlProperty + +dayProp :: JSString -> Day -> IntlProperty +dayProp n d = IntlProperty n (dayToJSVal d) + +timeProp :: JSString -> UTCTime -> IntlProperty +timeProp n t = IntlProperty n (timeToJSVal t) + +#ifdef __GHCJS__ +data ContextApiCall a = ContextApiCall JSString a [IntlProperty] JSVal + +instance ToJSVal a => ToJSVal (ContextApiCall a) where + toJSVal (ContextApiCall name a props ctx) = do + aRef <- toJSVal a + propsObj <- JSO.create + forM_ props $ \(IntlProperty n p) -> do + pRef <- toJSVal p + JSO.setProp n pRef propsObj + js_callContextAPI ctx name aRef propsObj + +formatCtx :: ToJSVal a => JSString -> JSString -> a -> [IntlProperty] -> PropertyOrHandler handler +formatCtx name func val options = PropertyFromContext name $ ContextApiCall func val options + +#else +formatCtx :: JSString -> JSString -> a -> [IntlProperty] -> PropertyOrHandler handler +formatCtx name _ _ _ = PropertyFromContext name $ \() -> () #endif + + -- | Use the IntlProvider to set the @locale@, @formats@, and @messages@ property. -intlProvider_ :: String -- ^ the locale to use +intlProvider_ :: JSString -- ^ the locale to use -> Maybe JSVal -- ^ 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 @@ -283,7 +300,7 @@ -> ReactElementM eventHandler a intlProvider_ locale mmsgs mformats = foreignClass js_intlProvider props where - props = catMaybes [ Just ("locale" @= locale) + props = catMaybes [ Just ("locale" &= locale) , (property "messages") <$> mmsgs , (property "formats" . Object) <$> mformats ] @@ -312,10 +329,10 @@ -- the number has not changed. 'formattedNumberProp' is needed if the formatted number has to be -- a property on another element, such as the placeholder for an input element. formattedNumberProp :: ToJSVal num - => String -- ^ the property to set + => JSString -- ^ the property to set -> num -- ^ the number to format - -> [Pair] -- ^ any options accepted by - -- + -> [IntlProperty] -- ^ any options accepted by + -- -> PropertyOrHandler handler formattedNumberProp name x options = formatCtx name "formatNumber" x options @@ -330,21 +347,21 @@ -- These properties coorespond directly the options accepted by -- . 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 + weekdayF :: Maybe JSString -- ^ possible values are narrow, short, and long + , eraF :: Maybe JSString -- ^ possible values are narrow, short, and long + , yearF :: Maybe JSString -- ^ possible values are numeric and 2-digit + , monthF :: Maybe JSString -- ^ possible values are numeric, 2-digit, narrow, short, and long + , dayF :: Maybe JSString -- ^ 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 + [ ("weekday"&=) <$> w + , ("era"&=) <$> e + , ("year"&=) <$> y + , ("month"&=) <$> m + , ("day"&=) <$> d ] -- | A short day format, where month is \"short\" and year and day are \"numeric\". @@ -363,19 +380,19 @@ -- These properties coorespond directly the options accepted by -- . 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 + hourF :: Maybe JSString -- ^ possible values are numeric and 2-digit + , minuteF :: Maybe JSString -- ^ possible values are numeric and 2-digit + , secondF :: Maybe JSString -- ^ possible values are numeric and 2-digit + , timeZoneNameF :: Maybe JSString -- ^ 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 + [ ("hour"&=) <$> h + , ("minute"&=) <$> m + , ("second"&=) <$> s + , ("timeZoneName"&=) <$> t ] -- | A default date and time format, using 'shortDate' and then numeric for hour, minute, and @@ -393,7 +410,7 @@ day_ :: DayFormat -> Day -> ReactElementM eventHandler () day_ fmt day = time_ [property "dateTime" dateRef] $ foreignClass js_formatDate props mempty where - dateRef = dayToRef day + dateRef = dayToJSVal day props = property "value" dateRef : dayFtoProps fmt -- | Display a 'UTCTime' using the given format. Despite giving the time in UTC, it will be @@ -402,7 +419,7 @@ utcTime_ :: (DayFormat, TimeFormat) -> UTCTime -> ReactElementM eventHandler () utcTime_ (dayFmt, timeF) t = time_ [property "dateTime" timeRef] $ foreignClass js_formatDate props mempty where - timeRef = timeToRef t + timeRef = timeToJSVal t props = property "value" timeRef : (dayFtoProps dayFmt ++ timeFtoProps timeF) -- | A raw class which allows custom @@ -413,46 +430,46 @@ 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 + valProp = property "value" $ either dayToJSVal timeToJSVal t -- | Format a day or time as a string, and then use it as the value for a property. 'day_', -- 'utcTime_', or 'formattedDate_' should be prefered because as components they can avoid re-rendering when -- the date has not changed. 'formattedDateProp' is needed if the formatted date has to be -- a property on another element, such as the placeholder for an input element. -formattedDateProp :: String -- ^ the property to set +formattedDateProp :: JSString -- ^ the property to set -> Either Day UTCTime -- ^ the day or time to format - -> [Pair] -- ^ Any options supported by - -- . + -> [IntlProperty] -- ^ Any options supported by + -- . -> PropertyOrHandler eventHandler formattedDateProp name (Left day) options = - formatCtx name "formatDate" (dayToRef day) options + formatCtx name "formatDate" (dayToJSVal day) options formattedDateProp name (Right time) options = - formatCtx name "formatTime" (timeToRef time) options + formatCtx name "formatTime" (timeToJSVal time) options -- | Display the 'UTCTime' as a relative time. In addition, wrap the display in a HTML5 -- element. relativeTo_ :: UTCTime -> ReactElementM eventHandler () relativeTo_ t = time_ [property "dateTime" timeRef] $ foreignClass js_formatRelative [property "value" timeRef] mempty where - timeRef = timeToRef t + timeRef = timeToJSVal t -- | Format the given UTCTime using the -- 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 +formattedRelative_ t props = foreignClass js_formatRelative (property "value" (timeToJSVal t) : props) mempty -- | Format a time as a relative time string, and then use it as the value for a property. -- 'relativeTo_' or 'formattedRelative_' should be prefered because as components they can avoid re-rendering when -- the date has not changed. 'formattedRelativeProp' is needed if the formatted date has to be -- a property on another element, such as the placeholder for an input element. -formattedRelativeProp :: String -- ^ te property to set +formattedRelativeProp :: JSString -- ^ te property to set -> UTCTime -- ^ the time to format - -> [Pair] -- ^ an object with properties \"units\" and \"style\". \"units\" accepts values second, minute, hour - -- day, month, or year and \"style\" accepts only the value \"numeric\". + -> [IntlProperty] -- ^ an object with properties \"units\" and \"style\". \"units\" accepts values second, minute, hour + -- day, month, or year and \"style\" accepts only the value \"numeric\". -> PropertyOrHandler eventHandler -formattedRelativeProp name time options = formatCtx name "formatRelative" (timeToRef time) options +formattedRelativeProp name time options = formatCtx name "formatRelative" (timeToJSVal time) options -------------------------------------------------------------------------------- -- Plural @@ -468,7 +485,7 @@ -- | Format a number properly based on pluralization, and then use it as the value for a property. -- 'plural_' should be preferred, but 'pluralProp' can be used in places where a component is not -- possible such as the placeholder of an input element. -pluralProp :: ToJSVal val => String -> val -> [Pair] -> PropertyOrHandler eventHandler +pluralProp :: ToJSVal val => JSString -> val -> [IntlProperty] -> PropertyOrHandler eventHandler pluralProp name val options = formatCtx name "formatPlural" val options -------------------------------------------------------------------------------- @@ -519,9 +536,9 @@ -> T.Text -- ^ The default message written in . -- 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 +message ident m = formatMessage [|js_formatMsg|] ident $ Message "" m --- | Similar to 'message', but produce an expression of type @['Pair'] -> PropertyOrHandler handler@, +-- | Similar to 'message', but produce an expression of type @['IntlProperty'] -> PropertyOrHandler handler@, -- which should be passed the values for the message. This allows you to format messages in places -- where using a component like 'message' is not possible, such as the placeholder of input -- elements. 'message' should be prefered since it can avoid re-rendering the formatting if the @@ -533,7 +550,7 @@ -- > , $(messageProp "placeholder" "ageplaceholder" "Hello {name}, enter your age") -- > [ "name" .= nameFrom storeData ] -- > ] -messageProp :: String -- ^ the property name to set +messageProp :: T.Text -- ^ the property name to set -> MessageId -- ^ the message identifier -> T.Text -- ^ the default message written in ICU message syntax. -> ExpQ @@ -545,10 +562,10 @@ -> 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 +message' ident descr m = formatMessage [|js_formatMsg|] ident $ Message descr m -- | A varient of 'messageProp' which allows you to specify some context for translators. -messageProp' :: String -- ^ property to set +messageProp' :: T.Text -- ^ property to set -> MessageId -> T.Text -- ^ A description intended to provide context for translators -> T.Text -- ^ The default message written in ICU message syntax @@ -563,14 +580,14 @@ htmlMsg :: MessageId -> T.Text -- ^ default message written in ICU message syntax -> ExpQ -htmlMsg ident m = formattedMessage [|js_formatHtmlMsg|] ident $ Message "" m +htmlMsg ident m = formatMessage [|js_formatHtmlMsg|] ident $ Message "" 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 +htmlMsg' ident descr m = formatMessage [|js_formatHtmlMsg|] ident $ Message descr m recordMessage :: MessageId -> Message -> Q () recordMessage ident m = do @@ -587,18 +604,30 @@ qPutQ $ H.insert ident (m, curLoc) mmap -- | Utility function for messages -formattedMessage :: ExpQ -> MessageId -> Message -> ExpQ --Q (TExp ([PropertyOrHandler eventHandler] -> ReactElementM eventHandler ())) -formattedMessage cls ident m = do +formatMessage :: ExpQ -> MessageId -> Message -> ExpQ --Q (TExp ([PropertyOrHandler eventHandler] -> ReactElementM eventHandler ())) +formatMessage cls ident m = do recordMessage ident m 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 |] -formatMessageProp :: String -> String -> MessageId -> Message -> ExpQ -- Q (TExp ([Pair] -> PropertyOrHandler eventHandler)) +formatMessageProp :: T.Text -> T.Text -> MessageId -> Message -> ExpQ -- Q (TExp ([IntlProperty] -> PropertyOrHandler eventHandler)) formatMessageProp func name ident m = do recordMessage ident m let liftedMsg = [| object ["id" .= T.pack $(liftString $ T.unpack ident), "defaultMessage" .= T.pack $(liftString $ T.unpack $ msgDefaultMsg m) ] |] - [|\options -> formatCtx $(liftString name) $(liftString func) $liftedMsg options |] + [|\options -> formatCtx (toJSString $(liftString $ T.unpack name)) (toJSString $(liftString $ T.unpack func)) $liftedMsg options |] + +-- | A raw @FormattedMessage@ element. The given properties are passed directly with no handling. +-- Any message is not recorded in Template Haskell and will not appear in any resulting message file +-- created by 'writeIntlMessages'. +formattedMessage_ :: [PropertyOrHandler eventHandler] -> ReactElementM eventHandler () +formattedMessage_ props = foreignClass js_formatMsg props mempty + +-- | A raw @FormattedHTMLMessage@ element. The given properties are passed directly with no handling. +-- Any message is not recorded in Template Haskell and will not appear in any resulting message file +-- created by 'writeIntlMessages'. +formattedHtmlMessage_ :: [PropertyOrHandler eventHandler] -> ReactElementM eventHandler () +formattedHtmlMessage_ props = foreignClass js_formatHtmlMsg props 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]@, diff --git a/src/React/Flux/Combinators.hs b/src/React/Flux/Combinators.hs --- a/src/React/Flux/Combinators.hs +++ b/src/React/Flux/Combinators.hs @@ -8,6 +8,7 @@ , faIcon_ , foreign_ , labeledInput_ + , style -- * Ajax , initAjax , jsonAjax @@ -32,7 +33,7 @@ import Control.DeepSeq (deepseq) import GHCJS.Foreign.Callback import GHCJS.Marshal (ToJSVal(..), toJSVal_aeson, FromJSVal(..)) -import GHCJS.Types (JSString, JSVal) +import GHCJS.Types (JSVal) import qualified Data.Text as T import qualified Data.JSString.Text as JSS @@ -44,8 +45,6 @@ #else js_lookupWindow :: a -> () js_lookupWindow _ = () - -type JSString = String #endif -- | A wrapper around 'foreignClass' that looks up the class on the `window`. I use it for several @@ -74,11 +73,11 @@ -- > ] -- > , callback "onChange" $ \(i :: String) -> dispatch $ ItemChangedTo i -- > ] -foreign_ :: String -- ^ this should be the name of a property on `window` which contains a react class. +foreign_ :: JSString -- ^ this should be the name of a property on `window` which contains a react class. -> [PropertyOrHandler handler] -- ^ properties -> ReactElementM handler a -- ^ children -> ReactElementM handler a -foreign_ x = foreignClass (js_lookupWindow $ toJSString x) +foreign_ x = foreignClass (js_lookupWindow x) -- | A 'div_' with the given class name (multiple classes can be separated by spaces). This is -- useful for defining rows and columns in your CSS framework of choice. I use @@ -88,28 +87,19 @@ -- > cldiv_ "pure-u-1-3" $ p_ "First Third" -- > cldiv_ "pure-u-1-3" $ p_ "Middle Third" -- > cldiv_ "pure-u-1-3" $ p_ "Last Third" --- --- You should consider writing something like the following for the various components in your frontend --- of choice. In PureCSS, I use: --- --- >prow_ :: ReactElementM handler a -> ReactElementM handler a --- >prow_ = cldiv_ "pure-g" --- > --- >pcol_ :: String -> ReactElementM handler a -> ReactElementM handler a --- >pcol_ cl = cldiv_ (unwords $ map ("pure-u-"++) $ words cl) -cldiv_ :: String -> ReactElementM handler a -> ReactElementM handler a -cldiv_ cl = div_ ["className" @= cl] +cldiv_ :: JSString -> ReactElementM handler a -> ReactElementM handler a +cldiv_ cl = div_ ["className" &= cl] -- | A 'button_' with the given class names and `onClick` handler. -- --- >clbutton_ ["pure-button button-success"] (dispatch LaunchTheMissiles) $ do +-- >clbutton_ "pure-button button-success" (dispatch LaunchTheMissiles) $ do -- > faIcon_ "rocket" -- > "Launch the missiles!" -clbutton_ :: String -- ^ class names separated by spaces +clbutton_ :: JSString -- ^ class names separated by spaces -> handler -- ^ the onClick handler for the button -> ReactElementM handler a -- ^ the children -> ReactElementM handler a -clbutton_ cl h = button_ ["className" @= cl, onClick (\_ _ -> h)] +clbutton_ cl h = button_ ["className" &= cl, onClick (\_ _ -> h)] -- | A 'label_' and an 'input_' together. Useful for laying out forms. For example, a -- stacked could be @@ -123,20 +113,25 @@ -- > ["type" $= "password"] -- -- The second 'labeledInput_' shows an example using "React.Flux.Addons.Intl". -labeledInput_ :: String -- ^ the ID for the input element +labeledInput_ :: JSString -- ^ the ID for the input element -> ReactElementM handler () -- ^ the label content. This is wrapped in a 'label_' with a `htmlFor` property -- equal to the given ID. -> [PropertyOrHandler handler] -- ^ the properties to pass to 'input_'. A property with key `id` is added to this list of properties. -> ReactElementM handler () -labeledInput_ ident lbl props = label_ ["htmlFor" @= ident] lbl <> input_ (("id" @= ident):props) +labeledInput_ ident lbl props = label_ ["htmlFor" &= ident] lbl <> input_ (("id" &= ident):props) -- | A icon. The given string is prefixed -- by `fa fa-` and then used as the class for an `i` element. This allows you to icons such as -- -- >faIcon_ "fighter-jet" -- produces -- >faIcon_ "refresh fa-spin" -- produces -faIcon_ :: String -> ReactElementM handler () -faIcon_ cl = i_ ["className" @= ("fa fa-" ++ cl)] mempty +faIcon_ :: JSString -> ReactElementM handler () +faIcon_ cl = i_ ["className" &= ("fa fa-" <> cl)] mempty + +-- | A simple combinator to easily write +-- on elements. +style :: [(JSString,JSString)] -> PropertyOrHandler handler +style = nestedProperty "style" . map (\(n,a) -> (n &= a)) -------------------------------------------------------------------------------- --- Ajax diff --git a/src/React/Flux/DOM.hs b/src/React/Flux/DOM.hs --- a/src/React/Flux/DOM.hs +++ b/src/React/Flux/DOM.hs @@ -51,7 +51,7 @@ -- | This class allows the DOM combinators to optionally take a list of properties or handlers, or -- for the list to be omitted. class Term eventHandler arg result | result -> arg, result -> eventHandler where - term :: String -> arg -> result + term :: JSString -> arg -> result instance (child ~ ReactElementM eventHandler a) => Term eventHandler [PropertyOrHandler eventHandler] (child -> ReactElementM eventHandler a) where term name props = el name props diff --git a/src/React/Flux/Internal.hs b/src/React/Flux/Internal.hs --- a/src/React/Flux/Internal.hs +++ b/src/React/Flux/Internal.hs @@ -2,22 +2,27 @@ -- -- Normally you should not need to use anything in this module. This module is only needed if you have -- complicated interaction with third-party javascript rendering code. + module React.Flux.Internal( ReactViewRef(..) - , ReactViewKey(..) , ReactElementRef(..) , HandlerArg(..) , PropertyOrHandler(..) , property + , (&=) , ReactElement(..) , ReactElementM(..) + , elemString , elemText + , elemJSString , elemShow , el , childrenPassedToView , elementToM , mkReactElement + , exportViewToJs , toJSString + , JSString ) where import Data.String (IsString(..)) @@ -25,10 +30,12 @@ import Data.Typeable (Typeable) import Control.Monad.Writer import Control.Monad.Identity (Identity(..)) +import qualified Data.Text as T #ifdef __GHCJS__ import Unsafe.Coerce import qualified Data.JSString as JSS +import qualified Data.JSString.Text as JSS import JavaScript.Array (JSArray) import qualified JavaScript.Array as JSA import GHCJS.Foreign.Callback @@ -39,7 +46,6 @@ import React.Flux.Export #else import Data.Text (Text) -type Callback a = () type JSVal = () class ToJSVal a instance ToJSVal Value @@ -47,6 +53,10 @@ instance ToJSVal () class IsJSVal a type JSArray = JSVal +type JSString = String +instance IsJSVal JSVal +instance IsJSVal JSString +instance ToJSVal JSString #endif -- type JSObject a = JSO.Object a @@ -72,29 +82,34 @@ -- passed as the second argument to @React.createElement@. data PropertyOrHandler handler = forall ref. ToJSVal ref => Property - { propertyName :: String + { propertyName :: JSString , propertyVal :: ref } | forall ref. ToJSVal ref => PropertyFromContext - { propFromThisName :: String + { propFromThisName :: JSString , propFromThisVal :: JSVal -> ref -- ^ will be passed this.context } | NestedProperty - { nestedPropertyName :: String + { nestedPropertyName :: JSString , nestedPropertyVals :: [PropertyOrHandler handler] } | ElementProperty - { elementPropertyName :: String + { elementPropertyName :: JSString , elementValue :: ReactElementM handler () } | CallbackPropertyWithArgumentArray - { caPropertyName :: String + { caPropertyName :: JSString , caFunc :: JSArray -> IO handler } | CallbackPropertyWithSingleArgument - { csPropertyName :: String + { csPropertyName :: JSString , csFunc :: HandlerArg -> handler } + | forall props. Typeable props => CallbackPropertyReturningView + { cretPropertyName :: JSString + , cretArgToProp :: JSArray -> IO props + , cretView :: ReactViewRef props + } instance Functor PropertyOrHandler where fmap _ (Property name val) = Property name val @@ -104,28 +119,16 @@ ElementProperty name $ ReactElementM $ mapWriter (\((),e) -> ((), fmap f e)) mkElem fmap f (CallbackPropertyWithArgumentArray name h) = CallbackPropertyWithArgumentArray name (fmap f . h) fmap f (CallbackPropertyWithSingleArgument name h) = CallbackPropertyWithSingleArgument name (f . h) + fmap _ (CallbackPropertyReturningView name f v) = CallbackPropertyReturningView name f v -- | Create a property from anything that can be converted to a JSVal -property :: ToJSVal val => String -> val -> PropertyOrHandler handler +property :: ToJSVal val => JSString -> val -> PropertyOrHandler handler property = Property --- | Keys in React can either be strings or integers -class ReactViewKey key where - toKeyRef :: key -> IO JSVal - -#if __GHCJS__ -instance ReactViewKey String where - toKeyRef = return . unsafeCoerce . toJSString - -instance ReactViewKey Int where - toKeyRef i = toJSVal i -#else -instance ReactViewKey String where - toKeyRef = const $ return () - -instance ReactViewKey Int where - toKeyRef = const $ return () -#endif +-- | Create a property for anything that can be converted to a javascript value using the @ToJSVal@ +-- class from the @ghcjs-base@ package.. This is just an infix version of 'property'. +(&=) :: ToJSVal a => JSString -> a -> PropertyOrHandler handler +n &= a = Property n a -- | A React element is a node or list of nodes in a virtual tree. Elements are the output of the -- rendering functions of classes. React takes the output of the rendering function (which is a @@ -134,19 +137,18 @@ -- elements are rendered into the browser DOM as siblings. data ReactElement eventHandler = ForeignElement - { fName :: Either String (ReactViewRef Object) + { fName :: Either JSString (ReactViewRef Object) , fProps :: [PropertyOrHandler eventHandler] , fChild :: ReactElement eventHandler } - | forall props key. (Typeable props, ReactViewKey key) => ViewElement + | forall props. Typeable props => ViewElement { ceClass :: ReactViewRef props - , ceKey :: Maybe key - -- TODO: ref? ref support would need to tie into the Class too. + , ceKey :: Maybe JSVal , ceProps :: props , ceChild :: ReactElement eventHandler } | ChildrenPassedToView - | Content String + | Content JSString | Append (ReactElement eventHandler) (ReactElement eventHandler) | EmptyElement @@ -200,22 +202,35 @@ in elementToM () $ Append e1' e2' instance (a ~ ()) => IsString (ReactElementM eventHandler a) where - fromString s = elementToM () $ Content s + fromString s = elementToM () $ Content $ toJSString s --- | Create a text element from a string. This is an alias for 'fromString'. The text content is --- escaped to be HTML safe. If you need to insert HTML, instead use the +-- | Create a text element from a string. The text content is escaped to be HTML safe. +-- If you need to insert HTML, instead use the -- --- property. -elemText :: String -> ReactElementM eventHandler () -elemText s = elementToM () $ Content s +-- property. This is an alias for 'fromString'. +elemString :: String -> ReactElementM eventHandler () +elemString s = elementToM () $ Content $ toJSString s +-- | Create a text element from a text value. The text content is escaped to be HTML safe. +elemText :: T.Text -> ReactElementM eventHandler () +#ifdef __GHCJS__ +elemText s = elementToM () $ Content $ JSS.textToJSString s +#else +elemText s = elementToM () $ Content $ T.unpack s +#endif + +-- | Create a text element from a @JSString@. This is more efficient for hard-coded strings than +-- converting from text to a JavaScript string. The string is escaped to be HTML safe. +elemJSString :: JSString -> ReactElementM eventHandler () +elemJSString s = elementToM () $ Content s + -- | Create an element containing text which is the result of 'show'ing the argument. -- Note that the resulting string is then escaped to be HTML safe. elemShow :: Show a => a -> ReactElementM eventHandler () -elemShow s = elementToM () $ Content $ show s +elemShow s = elementToM () $ Content $ toJSString $ show s -- | Create a React element. -el :: String -- ^ The element name (the first argument to @React.createElement@). +el :: JSString -- ^ The element name (the first argument to @React.createElement@). -> [PropertyOrHandler eventHandler] -- ^ The properties to pass to the element (the second argument to @React.createElement@). -> ReactElementM eventHandler a -- ^ The child elements (the third argument to @React.createElement@). -> ReactElementM eventHandler a @@ -233,6 +248,8 @@ -- mkReactElement has two versions ---------------------------------------------------------------------------------------------------- +type CallbackToRelease = JSVal + -- | Execute a ReactElementM to create a javascript React element and a list of callbacks attached -- to nodes within the element. These callbacks will need to be released with 'releaseCallback' -- once the class is re-rendered. @@ -241,7 +258,7 @@ -> IO JSVal -- ^ this.context -> IO [ReactElementRef] -- ^ this.props.children -> ReactElementM eventHandler () - -> IO (ReactElementRef, [Callback (JSVal -> IO ())]) + -> IO (ReactElementRef, [CallbackToRelease]) #ifdef __GHCJS__ @@ -252,47 +269,52 @@ mToElem eM = do let e = execWriter $ runReactElementM eM e' = case e of - Content txt -> ForeignElement (Left "span") [] (Content txt) + Content txt -> ForeignElement (Right $ ReactViewRef js_textWrapper) [] (Content txt) _ -> e refs <- createElement e' case refs of - [] -> lift $ js_ReactCreateElementNoChildren "div" + [] -> lift $ js_ReactCreateElementNoChildren js_divLikeElement [x] -> return x xs -> lift $ do emptyObj <- JSO.create let arr = jsval $ JSA.fromList $ map reactElementRef xs - js_ReactCreateElementName "div" emptyObj arr + js_ReactCreateForeignElement (ReactViewRef js_divLikeElement) emptyObj arr -- add the property or handler to the javascript object addPropOrHandlerToObj :: JSO.Object -> PropertyOrHandler eventHandler -> MkReactElementM () addPropOrHandlerToObj obj (Property n val) = lift $ do vRef <- toJSVal val - JSO.setProp (toJSString n) vRef obj + JSO.setProp n vRef obj addPropOrHandlerToObj obj (PropertyFromContext n f) = lift $ do ctx <- getContext vRef <- toJSVal $ f ctx - JSO.setProp (toJSString n) vRef obj + JSO.setProp n vRef obj addPropOrHandlerToObj obj (NestedProperty n vals) = do nested <- lift $ JSO.create mapM_ (addPropOrHandlerToObj nested) vals - lift $ JSO.setProp (toJSString n) (jsval nested) obj + lift $ JSO.setProp n (jsval nested) obj addPropOrHandlerToObj obj (ElementProperty name rM) = do ReactElementRef ref <- mToElem rM - lift $ JSO.setProp (toJSString name) ref obj + lift $ JSO.setProp name ref obj addPropOrHandlerToObj obj (CallbackPropertyWithArgumentArray name func) = do -- this will be released by the render function of the class (jsbits/class.js) cb <- lift $ syncCallback1 ContinueAsync $ \argref -> do handler <- func $ unsafeCoerce argref runHandler handler - tell [cb] + tell [jsval cb] wrappedCb <- lift $ js_CreateArgumentsCallback cb - lift $ JSO.setProp (toJSString name) wrappedCb obj + lift $ JSO.setProp 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 [jsval cb] + lift $ JSO.setProp name (jsval cb) obj + + addPropOrHandlerToObj obj (CallbackPropertyReturningView name toProps v) = do + (cb, wrappedCb) <- lift $ exportViewToJs v toProps tell [cb] - lift $ JSO.setProp (toJSString name) (jsval cb) obj + lift $ JSO.setProp name wrappedCb obj -- call React.createElement createElement :: ReactElement eventHandler -> MkReactElementM [ReactElementRef] @@ -309,7 +331,7 @@ [x] -> x xs -> jsval $ JSA.fromList xs e <- lift $ case fName f of - Left s -> js_ReactCreateElementName (toJSString s) obj children + Left s -> js_ReactCreateElementName s obj children Right ref -> js_ReactCreateForeignElement ref obj children return [e] createElement (ViewElement { ceClass = rc, ceProps = props, ceKey = mkey, ceChild = child }) = do @@ -322,17 +344,15 @@ xs -> jsval $ JSA.fromList xs e <- lift $ case mkey of - Just key -> do - keyRef <- toKeyRef key - js_ReactCreateKeyedElement rc keyRef propsE children + Just keyRef -> js_ReactCreateKeyedElement rc keyRef propsE children Nothing -> js_ReactCreateClass rc propsE children return [e] -type MkReactElementM a = WriterT [Callback (JSVal -> IO ())] IO a +type MkReactElementM a = WriterT [CallbackToRelease] IO a foreign import javascript unsafe "React['createElement']($1)" - js_ReactCreateElementNoChildren :: JSString -> IO ReactElementRef + js_ReactCreateElementNoChildren :: JSVal -> IO ReactElementRef foreign import javascript unsafe "React['createElement']($1, $2, $3)" @@ -354,16 +374,46 @@ "hsreact$mk_arguments_callback($1)" js_CreateArgumentsCallback :: Callback (JSVal -> IO ()) -> IO JSVal -js_ReactCreateContent :: String -> ReactElementRef -js_ReactCreateContent = ReactElementRef . unsafeCoerce . toJSString +foreign import javascript unsafe + "hsreact$wrap_callback_returning_element($1)" + js_wrapCallbackReturningElement :: Callback (JSVal -> JSVal -> IO ()) -> IO JSVal +foreign import javascript unsafe + "$1.elem = $2" + js_setElemReturnFromCallback :: JSVal -> ReactElementRef -> IO () + +foreign import javascript unsafe + "$r = hsreact$divLikeElement" + js_divLikeElement :: JSVal + +foreign import javascript unsafe + "$r = hsreact$textWrapper" + js_textWrapper :: JSVal + +js_ReactCreateContent :: JSString -> ReactElementRef +js_ReactCreateContent = ReactElementRef . unsafeCoerce + toJSString :: String -> JSString toJSString = JSS.pack + +exportViewToJs :: Typeable props => ReactViewRef props -> (JSArray -> IO props) -> IO (CallbackToRelease, JSVal) +exportViewToJs view toProps = do + cb <- syncCallback2 ContinueAsync $ \ret argref -> do + props <- toProps $ unsafeCoerce argref + propsE <- export props -- this will be released inside the lifetime events for the class + e <- js_ReactCreateClass view propsE jsNull + js_setElemReturnFromCallback ret e + wrappedCb <- js_wrapCallbackReturningElement cb + return (jsval cb, wrappedCb) + #else mkReactElement _ _ _ _ = return (ReactElementRef (), []) toJSString :: String -> String toJSString = id + +exportViewToJs :: Typeable props => ReactViewRef props -> (JSArray -> IO props) -> IO (CallbackToRelease, JSVal) +exportViewToJs _ _ = return ((), ()) #endif diff --git a/src/React/Flux/Lifecycle.hs b/src/React/Flux/Lifecycle.hs --- a/src/React/Flux/Lifecycle.hs +++ b/src/React/Flux/Lifecycle.hs @@ -68,7 +68,7 @@ -- 'lRef'. data LDOM = LDOM { lThis :: IO HTMLElement - , lRef :: String -> IO HTMLElement + , lRef :: JSString -> IO HTMLElement } -- | Set the state of the class. @@ -124,7 +124,7 @@ renderCb <- mkRenderCallback (js_ReactGetState >=> parseExport) runStateViewHandler render let dom this = LDOM { lThis = js_ReactFindDOMNode this - , lRef = \r -> js_ReactGetRef this $ toJSString r + , lRef = \r -> js_ReactGetRef this r } setStateFn this s = export s >>= js_ReactUpdateAndReleaseState this diff --git a/src/React/Flux/PropertiesAndEvents.hs b/src/React/Flux/PropertiesAndEvents.hs --- a/src/React/Flux/PropertiesAndEvents.hs +++ b/src/React/Flux/PropertiesAndEvents.hs @@ -11,10 +11,15 @@ , nestedProperty , CallbackFunction , callback + , callbackView + , ArgumentsToProps + , ReturnProps(..) + , callbackViewWithProps -- ** Combinators , (@=) , ($=) + , (&=) , classNames -- * Creating Events @@ -89,25 +94,27 @@ import Control.Concurrent.MVar (newMVar) import Control.DeepSeq import System.IO.Unsafe (unsafePerformIO) +import Data.Typeable (Typeable) +import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Aeson as A import qualified Data.HashMap.Strict as M import React.Flux.Internal import React.Flux.Store -import React.Flux.Views (ViewEventHandler, StatefulViewEventHandler) +import React.Flux.Views (ReactView(..), ViewEventHandler, StatefulViewEventHandler, ArgumentsToProps(..), ReturnProps(..)) #ifdef __GHCJS__ import Data.Maybe (fromMaybe) import GHCJS.Foreign (fromJSBool) import GHCJS.Marshal (FromJSVal(..)) -import GHCJS.Types (JSVal, nullRef, JSString, IsJSVal) +import GHCJS.Types (JSVal, nullRef, IsJSVal) import JavaScript.Array as JSA +import qualified Data.JSString.Text as JSS #else type JSVal = () -type JSString = String type JSArray = () class FromJSVal a class IsJSVal a @@ -118,7 +125,7 @@ -- | Some third-party React classes allow passing React elements as properties. This function -- will first run the given 'ReactElementM' to obtain an element or elements, and then use that -- element as the value for a property with the given key. -elementProperty :: String -> ReactElementM handler () -> PropertyOrHandler handler +elementProperty :: JSString -> ReactElementM handler () -> PropertyOrHandler handler elementProperty = ElementProperty -- | Allows you to create nested object properties. The list of properties passed in will be @@ -132,7 +139,7 @@ -- would create a javascript object -- -- >{"Hello": {a: 100, b: "World"}, "c": "!!!"} -nestedProperty :: String -> [PropertyOrHandler handler] -> PropertyOrHandler handler +nestedProperty :: JSString -> [PropertyOrHandler handler] -> PropertyOrHandler handler nestedProperty = NestedProperty -- | A class which is used to implement . @@ -176,21 +183,71 @@ -- >baz :: ViewEventHandler -- -- For another example, see the haddock comments in "React.Flux.Addons.Bootstrap". -callback :: CallbackFunction handler func => String -> func -> PropertyOrHandler handler +callback :: CallbackFunction handler func => JSString -> func -> PropertyOrHandler handler callback name func = CallbackPropertyWithArgumentArray name $ \arr -> applyFromArguments arr 0 func +-- | Create a zero-argument callback property. When this callback function is executed, it +-- will render the given view and return the resulting React element. If you need to +-- create a callback which expects arguments, use 'callbackViewWithProps' instead. +callbackView :: JSString -> ReactView () -> PropertyOrHandler handler +callbackView name v = CallbackPropertyReturningView name (const $ return ()) (reactView v) + +-- | Create a callback that when called will render a view. This is useful for interacting with third-party React classes that expect +-- a property which is a function which when called returns a React element. The way this works is +-- as follows: +-- +-- 1. You create a Haskell function which translates the javascript arguments of the callback into a Haskell +-- value of type @ReturnProps props@. This is a variable-argument function using the 'ArgumentsToProps' class. +-- For example, +-- +-- @ +-- data MyProps = MyProps { theInt :: Int, theString :: String } +-- myArgsToProps :: Int -> String -> ReturnProps MyProps +-- myArgsToProps i s = ReturnProps $ MyProps i s +-- @ +-- +-- 2. You create a view which receives these properties and renders itself. This view will not +-- receive any children. +-- +-- @ +-- myView :: ReactView MyProps +-- mYView = defineView "my view" $ \\myProps -> ... +-- @ +-- +-- 3. You can then use 'callbackViewWithProps' to create a property which is a JavaScript function. +-- When this JavaScript function is executed, the JavaScript arguments are converted to the props, +-- the view is rendered using the props, and the resulting React element is returned from the +-- JavaScript function. +-- +-- @ +-- someOtherView :: ReactView () +-- someOtherView = defineView "some other view" $ \\() -> +-- div_ $ +-- foreignClass_ "theForeginThing" +-- [ callbackViewWithProps "the_propname_to_pass_to_theForeignThing" myView myArgsToProps +-- , "hello" $= "world" +-- ] mempty +-- @ +-- +-- @theForeignThing@ React class will receive a property called +-- @the_propname_to_pass_to_theForeignThing@. The value of this property is a JavaScript +-- function which when executed will convert the arguments to @props@, render the view, and +-- return the resulting React element. +callbackViewWithProps :: (Typeable props, ArgumentsToProps props func) => JSString -> ReactView props -> func -> PropertyOrHandler handler +callbackViewWithProps name v func = CallbackPropertyReturningView name (\arr -> returnViewFromArguments arr 0 func) (reactView v) + ---------------------------------------------------------------------------------------------------- --- Combinators ---------------------------------------------------------------------------------------------------- --- | Create a property. -(@=) :: A.ToJSON a => T.Text -> a -> PropertyOrHandler handler -n @= a = Property (T.unpack n) (A.toJSON a) +-- | Create a property from any aeson value (the at sign looks like "A" for aeson) +(@=) :: A.ToJSON a => JSString -> a -> PropertyOrHandler handler +n @= a = Property n (A.toJSON a) -- | Create a text-valued property. This is here to avoid problems when OverloadedStrings extension -- is enabled -($=) :: T.Text -> T.Text -> PropertyOrHandler handler -n $= a = Property (T.unpack n) a +($=) :: JSString -> JSString -> PropertyOrHandler handler +n $= a = Property n a -- | Set the property to consist -- of all the names which are matched with True, allowing you to easily toggle class names based on @@ -213,12 +270,12 @@ show _ = "EventTarget" -- | Access a property in an event target -eventTargetProp :: FromJSVal val => EventTarget -> String -> val -eventTargetProp (EventTarget ref) key = ref .: toJSString key +eventTargetProp :: FromJSVal val => EventTarget -> JSString -> val +eventTargetProp (EventTarget ref) key = ref .: key -- | Every event in React is a synthetic event, a cross-browser wrapper around the native event. data Event = Event - { evtType :: String + { evtType :: T.Text , evtBubbles :: Bool , evtCancelable :: Bool , evtCurrentTarget :: EventTarget @@ -240,7 +297,7 @@ -- > ] -- -- In this case, @val@ would coorespond to the javascript expression @evt.target.value@. -target :: FromJSVal val => Event -> String -> val +target :: FromJSVal val => Event -> JSString -> val target e s = eventTargetProp (evtTarget e) s parseEvent :: HandlerArg -> Event @@ -257,16 +314,17 @@ , evtHandlerArg = arg } --- | 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 +-- | Use this to create an event handler for an event not covered by the rest of this module. +-- (Events are not covered if they don't have extra arguments that require special handling.) +-- For example, onPlay and onPause are events you could use with @on@. +on :: JSString -> (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. -on2 :: String -- ^ The event name +on2 :: JSString -- ^ The event name -> (HandlerArg -> detail) -- ^ A function parsing the details for the specific event. -> (Event -> detail -> handler) -- ^ The function implementing the handler. -> PropertyOrHandler handler @@ -334,7 +392,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 (CallbackPropertyWithSingleArgument n h) = CallbackPropertyWithSingleArgument (n ++ "Capture") h +capturePhase (CallbackPropertyWithSingleArgument n h) = CallbackPropertyWithSingleArgument (n <> "Capture") h capturePhase _ = error "You must use React.Flux.PropertiesAndEvents.capturePhase on an event handler" --------------------------------------------------------------------------------------------------- @@ -351,10 +409,10 @@ { keyEvtAltKey :: Bool , keyEvtCharCode :: Int , keyEvtCtrlKey :: Bool - , keyGetModifierState :: String -> Bool - , keyKey :: String + , keyGetModifierState :: T.Text -> Bool + , keyKey :: T.Text , keyCode :: Int - , keyLocale :: String + , keyLocale :: Maybe T.Text , keyLocation :: Int , keyMetaKey :: Bool , keyRepeat :: Bool @@ -434,7 +492,7 @@ , mouseClientX :: Int , mouseClientY :: Int , mouseCtrlKey :: Bool - , mouseGetModifierState :: String -> Bool + , mouseGetModifierState :: T.Text -> Bool , mouseMetaKey :: Bool , mousePageX :: Int , mousePageY :: Int @@ -549,7 +607,7 @@ touchAltKey :: Bool , changedTouches :: [Touch] , touchCtrlKey :: Bool - , touchGetModifierState :: String -> Bool + , touchGetModifierState :: T.Text -> Bool , touchMetaKey :: Bool , touchShiftKey :: Bool , touchTargets :: [Touch] @@ -669,8 +727,8 @@ "$1['getModifierState']($2)" js_GetModifierState :: JSVal -> JSString -> JSVal -getModifierState :: JSVal -> String -> Bool -getModifierState ref = fromJSBool . js_GetModifierState ref . toJSString +getModifierState :: JSVal -> T.Text -> Bool +getModifierState ref = fromJSBool . js_GetModifierState ref . JSS.textToJSString arrayLength :: JSArray -> Int arrayLength = JSA.length @@ -680,16 +738,16 @@ #else -js_getProp :: a -> String -> JSVal +js_getProp :: a -> JSString -> JSVal js_getProp _ _ = () -js_getArrayProp :: a -> String -> JSVal +js_getArrayProp :: a -> JSString -> JSVal js_getArrayProp _ _ = () -(.:) :: JSVal -> String -> b +(.:) :: JSVal -> JSString -> b _ .: _ = undefined -getModifierState :: JSVal -> String -> Bool +getModifierState :: JSVal -> T.Text -> Bool getModifierState _ _ = False arrayLength :: JSArray -> Int diff --git a/src/React/Flux/Store.hs b/src/React/Flux/Store.hs --- a/src/React/Flux/Store.hs +++ b/src/React/Flux/Store.hs @@ -39,7 +39,7 @@ -- plus node can also be used for unit testing. -- -- >data Todo = Todo { --- > todoText :: String +-- > todoText :: Text -- > , todoComplete :: Bool -- > , todoIsEditing :: Bool -- >} deriving (Show, Typeable) @@ -48,10 +48,10 @@ -- > todoList :: [(Int, Todo)] -- >} deriving (Show, Typeable) -- > --- >data TodoAction = TodoCreate String +-- >data TodoAction = TodoCreate Text -- > | TodoDelete Int -- > | TodoEdit Int --- > | UpdateText Int String +-- > | UpdateText Int Text -- > | ToggleAllComplete -- > | TodoSetComplete Int Bool -- > | ClearCompletedTodos diff --git a/src/React/Flux/Views.hs b/src/React/Flux/Views.hs --- a/src/React/Flux/Views.hs +++ b/src/React/Flux/Views.hs @@ -1,4 +1,5 @@ -- | Internal module containing the view definitions +{-# LANGUAGE UndecidableInstances #-} module React.Flux.Views where import Control.Monad.Writer @@ -13,11 +14,17 @@ import React.Flux.Export import JavaScript.Array import GHCJS.Foreign.Callback -import GHCJS.Types (JSVal, JSString, IsJSVal, jsval) -import GHCJS.Marshal (ToJSVal(..)) +import GHCJS.Types (JSVal, IsJSVal, nullRef) +import GHCJS.Marshal (ToJSVal(..), FromJSVal(..)) +import GHCJS.Marshal.Pure (PToJSVal(..)) +import qualified JavaScript.Array as JSA #else type JSVal = () +type JSArray = () +class FromJSVal a +pToJSVal :: a -> JSVal +pToJSVal _ = () #endif @@ -65,7 +72,7 @@ -- > mainSection_ todoState -- > todoFooter_ todoState defineControllerView :: (StoreData storeData, Typeable props) - => String -- ^ A name for this view, used only for debugging/console logging + => JSString -- ^ A name for this view, used only for debugging/console logging -> ReactStore storeData -- ^ The store this controller view should attach to. -> (storeData -> props -> ReactElementM ViewEventHandler ()) -- ^ The rendering function -> ReactView props @@ -75,7 +82,7 @@ defineControllerView name (ReactStore store _) buildNode = unsafePerformIO $ do let render sd props = return $ buildNode sd props renderCb <- mkRenderCallback (js_ReactGetState >=> parseExport) runViewHandler render - ReactView <$> js_createControllerView (toJSString name) store renderCb + ReactView <$> js_createControllerView name store renderCb -- | Transform a controller view handler to a raw handler. runViewHandler :: ReactThis state props -> ViewEventHandler -> IO () @@ -99,7 +106,7 @@ -- One option to implement views is to just use a Haskell function taking the @props@ as input and -- producing a 'ReactElementM'. For small views, such a Haskell function is ideal. -- Using a 'ReactView' provides more than just a Haskell function when used with a key property with --- 'viewWithKey'. The key property allows React to more easily reconcile the virtual DOM with the +-- 'viewWithSKey' and 'viewWithIKey'. The key property allows React to more easily reconcile the virtual DOM with the -- browser DOM. -- -- The following is two example views: @mainSection_@ is just a Haskell function and @todoItem@ @@ -147,9 +154,9 @@ -- > } -- > -- >todoItem_ :: (Int, Todo) -> ReactElementM eventHandler () --- >todoItem_ todo = viewWithKey todoItem (fst todo) todo mempty +-- >todoItem_ !todo = viewWithIKey todoItem (fst todo) todo mempty defineView :: Typeable props - => String -- ^ A name for this view, used only for debugging/console logging + => JSString -- ^ A name for this view, used only for debugging/console logging -> (props -> ReactElementM ViewEventHandler ()) -- ^ The rendering function -> ReactView props @@ -158,7 +165,7 @@ defineView name buildNode = unsafePerformIO $ do let render () props = return $ buildNode props renderCb <- mkRenderCallback (const $ return ()) runViewHandler render - ReactView <$> js_createView (toJSString name) renderCb + ReactView <$> js_createView name renderCb #else @@ -194,37 +201,37 @@ -- new state. Any more complicated state should be moved out into a (possibly new) store. -- -- >data TextInputArgs = TextInputArgs { --- > tiaId :: Maybe String --- > , tiaClass :: String --- > , tiaPlaceholder :: String --- > , tiaOnSave :: String -> [SomeStoreAction] --- > , tiaValue :: Maybe String +-- > tiaId :: Maybe JSString +-- > , tiaClass :: JSString +-- > , tiaPlaceholder :: JSString +-- > , tiaOnSave :: Text -> [SomeStoreAction] +-- > , tiaValue :: Maybe Text -- >} deriving (Typeable) -- > -- >todoTextInput :: ReactView TextInputArgs -- >todoTextInput = defineStatefulView "todo text input" "" $ \curText args -> -- > input_ $ --- > maybe [] (\i -> ["id" @= i]) (tiaId args) +-- > maybe [] (\i -> ["id" &= i]) (tiaId args) -- > ++ --- > [ "className" @= tiaClass args --- > , "placeholder" @= tiaPlaceholder args --- > , "value" @= curText --- > , "autoFocus" @= True +-- > [ "className" &= tiaClass args +-- > , "placeholder" &= tiaPlaceholder args +-- > , "value" &= curText +-- > , "autoFocus" &= True -- > , onChange $ \evt _ -> ([], Just $ target evt "value") -- > , onBlur $ \_ _ curState -> --- > if not (null curState) +-- > if not (Text.null curState) -- > then (tiaOnSave args curState, Just "") -- > else ([], Nothing) -- > , onKeyDown $ \_ evt curState -> --- > if keyCode evt == 13 && not (null curState) -- 13 is enter +-- > if keyCode evt == 13 && not (Text.null curState) -- 13 is enter -- > then (tiaOnSave args curState, Just "") -- > else ([], Nothing) -- > ] -- > -- >todoTextInput_ :: TextInputArgs -> ReactElementM eventHandler () --- >todoTextInput_ args = view todoTextInput args mempty +-- >todoTextInput_ !args = view todoTextInput args mempty defineStatefulView :: (Typeable state, NFData state, Typeable props) - => String -- ^ A name for this view, used only for debugging/console logging + => JSString -- ^ A name for this view, used only for debugging/console logging -> state -- ^ The initial state -> (state -> props -> ReactElementM (StatefulViewEventHandler state) ()) -- ^ The rendering function -> ReactView props @@ -235,7 +242,7 @@ initialRef <- export initial let render state props = return $ buildNode state props renderCb <- mkRenderCallback (js_ReactGetState >=> parseExport) runStateViewHandler render - ReactView <$> js_createStatefulView (toJSString name) initialRef renderCb + ReactView <$> js_createStatefulView name initialRef renderCb -- | Transform a stateful view event handler to a raw event handler runStateViewHandler :: (Typeable state, NFData state) @@ -360,7 +367,7 @@ (element, evtCallbacks) <- mkReactElement (runHandler this) getContext getPropsChildren node - evtCallbacksRef <- toJSVal $ map jsval evtCallbacks + evtCallbacksRef <- toJSVal evtCallbacks js_RenderCbSetResults arg evtCallbacksRef element parseExport :: Typeable a => Export a -> IO a @@ -385,12 +392,27 @@ -> ReactElementM eventHandler a view rc props (ReactElementM child) = let (a, childEl) = runWriter child - in elementToM a $ ViewElement (reactView rc) (Nothing :: Maybe Int) props childEl + in elementToM a $ ViewElement (reactView rc) Nothing props childEl --- | Create an element from a view, and also pass in a key property for the instance. Key --- properties speed up the --- of the virtual DOM with the DOM. The key does not need to be globally unqiue, it only needs to --- be unique within the siblings of an element. +-- | Keys in React can either be strings or integers +class ReactViewKey key where + toKeyRef :: key -> JSVal +#if __GHCJS__ +instance ReactViewKey String where + toKeyRef = pToJSVal + +instance ReactViewKey Int where + toKeyRef = pToJSVal +#else +instance ReactViewKey String where + toKeyRef = const () + +instance ReactViewKey Int where + toKeyRef = const () +#endif + +-- | A deprecated way to create a view with a key which has problems when OverloadedStrings is +-- active. Use 'viewWithSKey' or 'viewWithIKey' instead. viewWithKey :: (Typeable props, ReactViewKey key) => ReactView props -- ^ the view -> key -- ^ A value unique within the siblings of this element @@ -399,8 +421,33 @@ -> ReactElementM eventHandler a viewWithKey rc key props (ReactElementM child) = let (a, childEl) = runWriter child - in elementToM a $ ViewElement (reactView rc) (Just key) props childEl + in elementToM a $ ViewElement (reactView rc) (Just $ toKeyRef key) props childEl +-- | Create an element from a view, and also pass in a string key property for the instance. Key +-- properties speed up the +-- of the virtual DOM with the DOM. The key does not need to be globally unqiue, it only needs to +-- be unique within the siblings of an element. +viewWithSKey :: Typeable props + => ReactView props -- ^ the view + -> JSString -- ^ The key, a value unique within the siblings of this element + -> props -- ^ The properties to pass to the view instance + -> ReactElementM eventHandler a -- ^ The children of the view + -> ReactElementM eventHandler a +viewWithSKey rc key props (ReactElementM child) = + let (a, childEl) = runWriter child + in elementToM a $ ViewElement (reactView rc) (Just $ pToJSVal key) props childEl + +-- | Similar to 'viewWithSKey', but with an integer key instead of a string key. +viewWithIKey :: Typeable props + => ReactView props -- ^ the view + -> Int -- ^ The key, a value unique within the siblings of this element + -> props -- ^ The properties to pass to the view instance + -> ReactElementM eventHandler a -- ^ The children of the view + -> ReactElementM eventHandler a +viewWithIKey rc key props (ReactElementM child) = + let (a, childEl) = runWriter child + in elementToM a $ ViewElement (reactView rc) (Just $ pToJSVal key) props childEl + -- | Create a 'ReactElement' for a class defined in javascript. See -- 'React.Flux.Combinators.foreign_' for a convenient wrapper and some examples. foreignClass :: JSVal -- ^ The javascript reference to the class @@ -417,3 +464,90 @@ #else foreignClass _ _ x = x #endif + +-- | A class which is used to implement . +-- These variable argument functions are used to convert from a JavaScript +-- +-- to a Haskell value of type @props@. +-- +-- Any function where each argument implements 'FromJSVal' and the result is 'ReturnProps' is an +-- instance of this class. Entries from the JavaScript arguments array are matched one-by-one to +-- the arguments before 'ReturnProps' value. If the Haskell function has more parameters than the +-- javascript @arguments@ object, a javascript null is used for the conversion. Since the 'Maybe' +-- instance of 'FromJSVal' converts null references to 'Nothing', you can exploit this to handle +-- arguments not given to the JavaScript function. +class ArgumentsToProps props a | a -> props where + returnViewFromArguments :: JSArray -> Int -> a -> IO props + +-- | A type needed to make GHC happy when solving for instances of 'ArgumentsToProps'. +newtype ReturnProps props = ReturnProps props + +instance ArgumentsToProps props (ReturnProps props) where + returnViewFromArguments _ _ (ReturnProps v) = return v + +instance (FromJSVal a, ArgumentsToProps props b) => ArgumentsToProps props (a -> b) where +#if __GHCJS__ + returnViewFromArguments args k f = do + ma <- fromJSVal $ if k >= JSA.length args then nullRef else JSA.index k args + a <- maybe (error "Unable to decode callback argument") return ma + returnViewFromArguments args (k+1) $ f a +#else + returnViewFromArguments _ _ _ = error "Not supported in GHC" +#endif + +-- | Export a Haskell view to a JavaScript function. This allows you to embed a Haskell react-flux +-- application into a larger existing JavaScript React application. If you want to use JavaScript +-- classes in your Haskell application, you should instead use 'React.Flux.Combinators.foreign_' and 'foreignClass'. +-- +-- The way this works is as follows: +-- +-- 1. You create a Haskell function which translates the javascript arguments of into a Haskell +-- value of type @ReturnProps props@. This is a variable-argument function using the 'ArgumentsToProps' class. +-- For example, +-- +-- @ +-- data MyProps = MyProps { theInt :: Int, theString :: String } +-- myArgsToProps :: Int -> String -> ReturnProps MyProps +-- myArgsToProps i s = ReturnProps $ MyProps i s +-- @ +-- +-- 2. You create a view which receives these properties and renders itself. This view will not +-- receive any children. +-- +-- @ +-- myView :: ReactView MyProps +-- myView = defineView "my view" $ \\myProps -> ... +-- @ +-- +-- 3. You can then use 'exportViewToJavaScript' to create a JavaScript function. When this +-- JavaScript function is executed, the JavaScript arguments are converted to the props, +-- the view is rendered using the props, and the resulting React element is returned from the +-- JavaScript function. +-- +-- @ +-- foreign import javascript unsafe +-- "window[\'myHaskellView\'] = $1;" +-- js_setMyView :: JSVal -> IO () +-- +-- exportMyView :: IO () +-- exportMyView = exportViewToJavaScript myView myArgsToProps >>= js_setMyView +-- @ +-- +-- @exportMyView@ should be called from your main function. After executing @exportMyView@, +-- the @window.myHaskellView@ property will be a javascript function. +-- +-- 4. Call the javascript function with two arguments to return a React element which can be used +-- in a JavaScript React class rendering function. +-- +-- @ +-- var myJsView = React.createClass({ +-- render: function() { +-- return \{window.myHaskellView(5, "Hello World")}\; +-- } +-- }; +-- @ +exportViewToJavaScript :: (Typeable props, ArgumentsToProps props func) => ReactView props -> func -> IO JSVal +exportViewToJavaScript v func = do + (_callbackToRelease, wrappedCb) <- exportViewToJs (reactView v) (\arr -> returnViewFromArguments arr 0 func) + return wrappedCb + diff --git a/test/client/TestClient.hs b/test/client/TestClient.hs --- a/test/client/TestClient.hs +++ b/test/client/TestClient.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables, DeriveAnyClass, FlexibleInstances, DeriveGeneric #-} -module TestClient (testClient) where +{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables, DeriveAnyClass, + FlexibleInstances, DeriveGeneric, BangPatterns, TemplateHaskell #-} +module Main (main) where import Control.DeepSeq (NFData) import Control.Monad @@ -8,14 +9,16 @@ import Data.Maybe import Debug.Trace import GHC.Generics (Generic) +import Data.Time (UTCTime(..), fromGregorian) import React.Flux import React.Flux.Lifecycle -import React.Flux.Internal (toJSString) import React.Flux.Addons.React -import React.Flux.Addons.Bootstrap +import React.Flux.Addons.Intl +import qualified Data.Text as T import GHCJS.Types (JSVal, JSString) import GHCJS.Marshal (fromJSVal) +import qualified Data.JSString.Text as JSS foreign import javascript unsafe "(function(x) { \ @@ -28,31 +31,34 @@ deriving (Show, Typeable) instance StoreData OutputStoreData where - type StoreAction OutputStoreData = [String] + type StoreAction OutputStoreData = [T.Text] -- log both to the console and to js_output transform ss OutputStoreData = do - mapM_ (js_output . toJSString) ss - trace (unlines ss) $ return OutputStoreData + mapM_ (js_output . JSS.textToJSString) ss + trace (unlines $ map T.unpack ss) $ return OutputStoreData outputStore :: ReactStore OutputStoreData outputStore = mkStore OutputStoreData -output :: [String] -> [SomeStoreAction] +output :: [T.Text] -> [SomeStoreAction] output s = [SomeStoreAction outputStore s] -outputIO :: [String] -> IO () +outputIO :: [T.Text] -> IO () outputIO ss = void $ transform ss OutputStoreData -------------------------------------------------------------------------------- --- Events -------------------------------------------------------------------------------- -logM :: (String -> Bool) -> String -logM f = "alt modifier: " ++ show (f "Alt") +logM :: (T.Text -> Bool) -> T.Text +logM f = "alt modifier: " <> (T.pack $ show (f "Alt")) -logT :: EventTarget -> String +logT :: EventTarget -> T.Text logT t = eventTargetProp t "id" +tshow :: Show a => a -> T.Text +tshow = T.pack . show + rawShowView :: ReactView Int rawShowView = defineView "raw show view" elemShow @@ -64,15 +70,15 @@ , "placeholder" $= "onKeyDown" , onKeyDown $ \e k -> output [ "keydown" - , show e - , show k + , tshow e + , tshow k , logM (keyGetModifierState k) , logT (evtTarget e) , logT (evtCurrentTarget e) ] , onFocus $ \e _ -> output [ "focus" - , show e + , tshow e --, logT $ focusRelatedTarget f ] ] @@ -80,8 +86,8 @@ p_ $ label_ [ "id" $= "clickinput" , onClick $ \e m -> output [ "click" - , show e - , show m + , tshow e + , tshow m , logM (mouseGetModifierState m) --, logT (mouseRelatedTarget m) ] @@ -91,8 +97,8 @@ p_ $ label_ [ "id" $= "touchinput" , onTouchStart $ \e t -> output [ "touchstart" - , show e - , show t + , tshow e + , tshow t , logM (touchGetModifierState t) , logT (touchTarget $ head $ touchTargets t) , "endtouch" @@ -127,11 +133,11 @@ --- Lifecycle -------------------------------------------------------------------------------- -logPandS :: LPropsAndState String Int -> IO () +logPandS :: LPropsAndState T.Text Int -> IO () logPandS ps = do p <- lGetProps ps st <- lGetState ps - outputIO ["Current props and state: " ++ p ++ ", " ++ show st] + outputIO ["Current props and state: " <> p <> ", " <> (T.pack $ show st)] foreign import javascript unsafe "$1.id" @@ -142,18 +148,18 @@ this <- lThis dom >>= js_domGetId >>= fromJSVal x <- lRef dom "refSt" >>= js_domGetId >>= fromJSVal y <- lRef dom "refProps" >>= js_domGetId >>= fromJSVal - outputIO [ "this id = " ++ fromMaybe "Nothing" this - , "refStr id = " ++ fromMaybe "Nothing" x - , "refProps id = " ++ fromMaybe "Nothing" y + outputIO [ "this id = " <> fromMaybe "Nothing" this + , "refStr id = " <> fromMaybe "Nothing" x + , "refProps id = " <> fromMaybe "Nothing" y ] -testLifecycle :: ReactView String +testLifecycle :: ReactView T.Text testLifecycle = defineLifecycleView "testlifecycle" (12 :: Int) lifecycleConfig { lRender = \s p -> p_ ["id" $= "lifecycle-p"] $ do span_ "Current state: " span_ ["ref" $= "refSt", "id" $= "hello"] (elemShow s) - span_ ["ref" $= "refProps", "id" $= "world"] $ elemText $ "Current props: " ++ p + span_ ["ref" $= "refProps", "id" $= "world"] $ elemText $ "Current props: " <> p button_ [ "id" $= "increment-state" , onClick $ \_ _ st -> ([], Just $ st + 1) ] "Incr" @@ -171,24 +177,24 @@ , lComponentWillReceiveProps = Just $ \pAndS _dom _setStateFn newProps -> do outputIO ["will recv props"] logPandS pAndS - outputIO ["New props: " ++ newProps] + outputIO ["New props: " <> newProps] , lComponentWillUpdate = Just $ \pAndS _dom newProps newState -> do outputIO ["will update"] logPandS pAndS - outputIO ["New props: " ++ newProps, "New state: " ++ show newState] + outputIO ["New props: " <> newProps, "New state: " <> tshow newState] , lComponentDidUpdate = Just $ \pAndS _dom _setStateFn oldProps oldState -> do outputIO ["did update"] logPandS pAndS - outputIO ["Old props: " ++ oldProps, "Old state: " ++ show oldState] + outputIO ["Old props: " <> oldProps, "Old state: " <> tshow oldState] , lComponentWillUnmount = Just $ \pAndS _dom -> do outputIO ["will unmount"] logPandS pAndS } -testLifecycle_ :: String -> ReactElementM eventHandler () +testLifecycle_ :: T.Text -> ReactElementM eventHandler () testLifecycle_ s = view testLifecycle s $ span_ ["id" $= "child-passed-to-view"] "I am a child!!!" -------------------------------------------------------------------------------- @@ -213,7 +219,7 @@ --- CSS Transitions -------------------------------------------------------------------------------- -cssTransitions :: ReactView [String] +cssTransitions :: ReactView [T.Text] cssTransitions = defineView "css transitions" $ \items -> div_ ["id" $= "css-transitions"] $ cssTransitionGroup ["transitionName" $= "example"] $ @@ -221,77 +227,250 @@ 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 +-- | The data in the store is four 'ShouldComponentUpdateData's. The reason is we test +-- views with tuples of size up to 3, and so we want 4 entries in the store to be able to +-- test editing the store but not changing anything that is passed to a view, to test that +-- the shouldComponentUpdate function is working properly. +data ShouldComponentUpdate = ShouldComponentUpdate { + scu1 :: !ShouldComponentUpdateData -- ^ passed to all three views + , scu2 :: !ShouldComponentUpdateData -- ^ only passed to the pair view + , scu3 :: !ShouldComponentUpdateData -- ^ only passed to the triple view + , scu4 :: !ShouldComponentUpdateData -- ^ not passed to any view +} deriving (Typeable, Show) + +data SCUIndex = SCU1 | SCU2 | SCU3 | SCU4 + deriving (Show, Eq, Typeable, Generic, NFData, Bounded, Enum) + +data ShouldComponentUpdateAction = IncrementAllSCUData SCUIndex + | IncrementFirstSCUData SCUIndex | NoChangeToSCUData - deriving (Show, Typeable, Generic, NFData) + 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" +toggleSCU :: ShouldComponentUpdateData -> ShouldComponentUpdateData +toggleSCU (ShouldComponentUpdateData i s) = ShouldComponentUpdateData (i+1) s -shouldComponentUpdateStore :: ReactStore [ShouldComponentUpdateData] -shouldComponentUpdateStore = mkStore [ ShouldComponentUpdateData 1 "Hello" - , ShouldComponentUpdateData 2 "World" - , ShouldComponentUpdateData 3 "!!!" - ] +instance StoreData [ShouldComponentUpdate] where + type StoreAction [ShouldComponentUpdate] = ShouldComponentUpdateAction + transform _ [] = error "Will never happen" + transform action ds@(first:rest) = + pure $ case action of + NoChangeToSCUData -> ds + (IncrementAllSCUData SCU1) -> [ShouldComponentUpdate (toggleSCU s1) s2 s3 s4 | ShouldComponentUpdate s1 s2 s3 s4 <- ds] + (IncrementAllSCUData SCU2) -> [ShouldComponentUpdate s1 (toggleSCU s2) s3 s4 | ShouldComponentUpdate s1 s2 s3 s4 <- ds] + (IncrementAllSCUData SCU3) -> [ShouldComponentUpdate s1 s2 (toggleSCU s3) s4 | ShouldComponentUpdate s1 s2 s3 s4 <- ds] + (IncrementAllSCUData SCU4) -> [ShouldComponentUpdate s1 s2 s3 (toggleSCU s4) | ShouldComponentUpdate s1 s2 s3 s4 <- ds] + (IncrementFirstSCUData SCU1) -> first { scu1 = toggleSCU $ scu1 first } : rest + (IncrementFirstSCUData SCU2) -> first { scu2 = toggleSCU $ scu2 first } : rest + (IncrementFirstSCUData SCU3) -> first { scu3 = toggleSCU $ scu3 first } : rest + (IncrementFirstSCUData SCU4) -> first { scu4 = toggleSCU $ scu4 first } : rest +shouldComponentUpdateStore :: ReactStore [ShouldComponentUpdate] +shouldComponentUpdateStore = mkStore + [ ShouldComponentUpdate (mkS 1 "Quick Ben") (mkS 2 "Whiskeyjack") (mkS 3 "Fiddler") (mkS 4 "Kellanved") + , ShouldComponentUpdate (mkS 5 "Karsa") (mkS 6 "Tehol") (mkS 7 "Tayschrenn") (mkS 8 "Kruppe") + , ShouldComponentUpdate (mkS 9 "Anomander Rake") (mkS 10 "Iskaral Pust") (mkS 11 "Dujek") (mkS 12 "Tavore") + ] + where + mkS = ShouldComponentUpdateData + -- | This will log wheenver componentWillUpdate lifecycle event occurs logComponentWillUpdate :: ReactView ShouldComponentUpdateData -logComponentWillUpdate = defineLifecycleView "shouldComponentUpdate spec" () lifecycleConfig +logComponentWillUpdate = defineLifecycleView "shouldComponentUpdate single spec" () lifecycleConfig { lRender = \() (ShouldComponentUpdateData i s) -> - span_ (elemShow i) <> span_ (elemText s) + span_ (elemShow i) <> span_ (elemString 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 + outputIO [ "Component will update single" + , "current props: " <> tshow curI <> " " <> T.pack curS + , "new props: " <> tshow newI <> " " <> T.pack newS ] } +logComp1_ :: ShouldComponentUpdateData -> Int -> ReactElementM handler () +logComp1_ !sc i = viewWithKey logComponentWillUpdate i sc mempty + +logComponentWillUpdatePair :: ReactView (ShouldComponentUpdateData, ShouldComponentUpdateData) +logComponentWillUpdatePair = defineLifecycleView "shouldComponentUpdate pair spec" () lifecycleConfig + { lRender = \() (ShouldComponentUpdateData i1 s1, ShouldComponentUpdateData i2 s2) -> + span_ (elemShow i1) <> span_ (elemString s1) <> span_ (elemShow i2) <> span_ (elemString s2) + , lComponentWillUpdate = Just $ \curProps _ (ShouldComponentUpdateData newI1 newS1, ShouldComponentUpdateData newI2 newS2) () -> do + (ShouldComponentUpdateData curI1 curS1, ShouldComponentUpdateData curI2 curS2) <- lGetProps curProps + outputIO [ "Component will update for pair input view" + , T.pack $ "current props: " ++ show curI1 ++ " " ++ curS1 ++ " " ++ show curI2 ++ " " ++ curS2 + , T.pack $ "new props: " ++ show newI1 ++ " " ++ newS1 ++ " " ++ show newI2 ++ " " ++ newS2 + ] + } + +logComp2_ :: ShouldComponentUpdateData -> ShouldComponentUpdateData -> Int -> ReactElementM handler () +logComp2_ !sc1 !sc2 i = viewWithKey logComponentWillUpdatePair i (sc1, sc2) mempty + +logComponentWillUpdateTriple :: ReactView (ShouldComponentUpdateData, ShouldComponentUpdateData, ShouldComponentUpdateData) +logComponentWillUpdateTriple = defineLifecycleView "shouldComponentUpdate triple spec" () lifecycleConfig + { lRender = \() (ShouldComponentUpdateData i1 s1, ShouldComponentUpdateData i2 s2, ShouldComponentUpdateData i3 s3) -> + span_ (elemShow i1) <> span_ (elemString s1) <> span_ (elemShow i2) <> span_ (elemString s2) <> span_ (elemShow i3) <> span_ (elemString s3) + , lComponentWillUpdate = Just $ \curProps _ + (ShouldComponentUpdateData newI1 newS1, ShouldComponentUpdateData newI2 newS2, ShouldComponentUpdateData newI3 newS3) () -> do + (ShouldComponentUpdateData curI1 curS1, ShouldComponentUpdateData curI2 curS2, ShouldComponentUpdateData curI3 curS3) <- lGetProps curProps + outputIO [ "Component will update for triple input view" + , T.pack $ "current props: " ++ show curI1 ++ " " ++ curS1 ++ " " ++ show curI2 ++ " " ++ curS2 ++ " " ++ show curI3 ++ " " ++ curS3 + , T.pack $ "new props: " ++ show newI1 ++ " " ++ newS1 ++ " " ++ show newI2 ++ " " ++ newS2 ++ " " ++ show newI3 ++ " " ++ newS3 + ] + } + +logComp3_ :: ShouldComponentUpdateData -> ShouldComponentUpdateData -> ShouldComponentUpdateData -> Int -> ReactElementM handler () +logComp3_ !sc1 !sc2 !sc3 i = viewWithKey logComponentWillUpdateTriple i (sc1, sc2, sc3) mempty + 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 + ul_ ["id" $= "should-component-update-single"] $ forM_ (zip ds [(0 :: Int)..]) $ \(d,i) -> + li_ $ logComp1_ (scu1 d) i + ul_ ["id" $= "should-component-update-pair"] $ forM_ (zip ds [(0 :: Int)..]) $ \(d,i) -> + li_ $ logComp2_ (scu1 d) (scu2 d) i + ul_ ["id" $= "should-component-update-triple"] $ forM_ (zip ds [(0 :: Int)..]) $ \(d, i) -> + li_ $ logComp3_ (scu1 d) (scu2 d) (scu3 d) i button_ ["id" $= "no-change-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore NoChangeToSCUData]] "No change to data" - button_ ["id" $= "change-all-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore IncrementAllSCUData]] - "Increment all" + forM_ [minBound..maxBound] $ \idx -> do + button_ ["id" @= ("change-all-scu-" ++ show idx), onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore $ IncrementAllSCUData idx]] $ + elemString $ "Increment all " ++ show idx + button_ ["id" @=("increment-first-scu" ++ show idx), onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore $ IncrementFirstSCUData idx]] $ + elemString $ "Increment first entry's integer" ++ show idx - button_ ["id" $= "increment-first-scu", onClick $ \_ _ -> [SomeStoreAction shouldComponentUpdateStore IncrementFirstSCUData]] - "Increment first entry's integer" +-------------------------------------------------------------------------------- +--- Callback returning view +-------------------------------------------------------------------------------- +data CallbackViewProps = CallbackViewProps Int String + deriving (Show, Typeable) + +callbackArgsToProps :: Int -> String -> ReturnProps CallbackViewProps +callbackArgsToProps i s = ReturnProps $ CallbackViewProps i s + +callbackViewTest :: ReactView CallbackViewProps +callbackViewTest = defineView "callback view props test" $ \(CallbackViewProps i s) -> + p_ [ "id" $= "callback-view-props-test"] $ + elemString $ "Props are " ++ show i ++ " and " ++ s + +foreign import javascript unsafe + "React['createClass']({'displayName':'callback wrapper', 'render': function() { \ + \ return React['createElement']('div', {}, [React.createElement('p', {}, 'From Callback'), this.props.foo(5, 'Hello World')]); \ + \ }})" + js_createWrapperClass :: JSVal + +callbackViewWrapper :: ReactView () +callbackViewWrapper = defineView "callback view wrapper" $ \() -> + div_ ["id" $= "callback-view-wrapper"] $ + foreignClass js_createWrapperClass [ callbackViewWithProps "foo" callbackViewTest callbackArgsToProps ] mempty + -------------------------------------------------------------------------------- +--- Intl +-------------------------------------------------------------------------------- + +foreign import javascript unsafe + "{'with_trans': 'message from translation {abc}'}" + js_translations :: JSVal + +intlSpec :: ReactView () +intlSpec = defineView "intl" $ \() -> + intlProvider_ "en" (Just js_translations) Nothing $ + view intlSpecBody () mempty + +intlSpecBody :: ReactView () +intlSpecBody = defineView "intl body" $ \() -> div_ ["id" $= "intl-spec"] $ + 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 + li_ ["id" $= "f-number-prop"] $ + input_ [formattedNumberProp "placeholder" (123456 :: Int) []] + + 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" ] + li_ ["id" $= "f-date-prop"] $ + input_ [formattedDateProp "placeholder" (Left moon) []] + + 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-time-prop"] $ + input_ [formattedDateProp "placeholder" (Right step) + [ "year" `iprop` ("2-digit" :: String) + , "month" `iprop` ("short" :: String) + , "day" `iprop` ("2-digit" :: String) + , "hour" `iprop` ("numeric" :: String) + , "timeZone" `iprop` ("Pacific/Tahiti" :: String) + ] + ] + + 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-plural-prop"] $ + input_ [pluralProp "placeholder" (100 :: Int) ["one" `iprop` ("plural one" :: String), "other" `iprop` ("plural other" :: String)]] + + 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-prop"] $ + input_ [ $(messageProp "placeholder" "photosprop" "{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}}") + [ "name" `iprop` ("Neil Armstrong" :: String) + , "numPhotos" `iprop` (100 :: Int) + ] + ] + + 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-msg-prop-with-descr"] $ + input_ [$(messageProp' "placeholder" "photosprop2" "How many photos?" "{name} took {numPhotos, number} photos") + [ "name" `iprop` ("Neil Armstrong" :: String) + , "numPhotos" `iprop` (0 :: Int) + ] + ] + + li_ ["id" $= "f-html-msg"] $ + $(htmlMsg "html1" "{num} 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 answer to life, the universe, and everything") + [ "num" @= (42 :: Int) ] + +-------------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------------- @@ -304,7 +483,7 @@ when (s /= "") $ testLifecycle_ s button_ [ "id" $= "add-app-str" - , onClick $ \_ _ s' -> ([], Just $ s' ++ "o") + , onClick $ \_ _ s' -> ([], Just $ s' <> "o") ] "Add o" button_ [ "id" $= "clear-app-str" @@ -315,7 +494,16 @@ view cssTransitions ["A", "B"] mempty - view bootstrapSpec () mempty - view shouldComponentUpdateSpec () mempty + + view callbackViewWrapper () mempty + + view intlSpec () mempty } + +main :: IO () +main = reactRender "app" testClient () + +writeIntlMessages (intlFormatJson "test/client/msgs/jsonmsgs.json") +writeIntlMessages (intlFormatJsonWithoutDescription "test/client/msgs/jsonnodescr.json") +writeIntlMessages (intlFormatAndroidXML "test/client/msgs/android.xml") diff --git a/test/client/TestClient13.hs b/test/client/TestClient13.hs deleted file mode 100644 --- a/test/client/TestClient13.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main (main) where - -import TestClient -import React.Flux - -main :: IO () -main = do - initializeTouchEvents - reactRender "app" testClient () diff --git a/test/client/TestClient14.hs b/test/client/TestClient14.hs deleted file mode 100644 --- a/test/client/TestClient14.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, ScopedTypeVariables, TemplateHaskell #-} -module Main (main) where - -import Data.Time -import React.Flux -import React.Flux.Addons.Intl -import GHCJS.Types (JSVal) -import Data.Aeson ((.=)) - -import TestClient - --------------------------------------------------------------------------------- ---- Intl --------------------------------------------------------------------------------- - -foreign import javascript unsafe - "{'with_trans': 'message from translation {abc}'}" - js_translations :: JSVal - -intlSpec :: ReactView () -intlSpec = defineView "intl" $ \() -> - intlProvider_ "en" (Just js_translations) Nothing $ - view intlSpecBody () mempty - -intlSpecBody :: ReactView () -intlSpecBody = defineView "intl body" $ \() -> div_ ["id" $= "intl-spec"] $ - 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 - li_ ["id" $= "f-number-prop"] $ - input_ [formattedNumberProp "placeholder" (123456 :: Int) []] - - 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" ] - li_ ["id" $= "f-date-prop"] $ - input_ [formattedDateProp "placeholder" (Left moon) []] - - 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-time-prop"] $ - input_ [formattedDateProp "placeholder" (Right step) - [ "year" .= ("2-digit" :: String) - , "month" .= ("short" :: String) - , "day" .= ("2-digit" :: String) - , "hour" .= ("numeric" :: String) - , "timeZone" .= ("Pacific/Tahiti" :: String) - ] - ] - - 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-plural-prop"] $ - input_ [pluralProp "placeholder" (100 :: Int) ["one" .= ("plural one" :: String), "other" .= ("plural other" :: String)]] - - 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-prop"] $ - input_ [ $(messageProp "placeholder" "photosprop" "{name} took {numPhotos, plural, =0 {no photos} =1 {one photo} other {# photos}}") - [ "name" .= ("Neil Armstrong" :: String) - , "numPhotos" .= (100 :: Int) - ] - ] - - 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-msg-prop-with-descr"] $ - input_ [$(messageProp' "placeholder" "photosprop2" "How many photos?" "{name} took {numPhotos, number} photos") - [ "name" .= ("Neil Armstrong" :: String) - , "numPhotos" .= (0 :: Int) - ] - ] - - li_ ["id" $= "f-html-msg"] $ - $(htmlMsg "html1" "{num} 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 answer 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") diff --git a/test/client/test-client.html b/test/client/test-client.html new file mode 100644 --- /dev/null +++ b/test/client/test-client.html @@ -0,0 +1,13 @@ + + + Test Client + + +
+ + + + + + + diff --git a/test/client/test-client13.html b/test/client/test-client13.html deleted file mode 100644 --- a/test/client/test-client13.html +++ /dev/null @@ -1,12 +0,0 @@ - - - Test Client - - -
- - - - - - diff --git a/test/client/test-client14.html b/test/client/test-client14.html deleted file mode 100644 --- a/test/client/test-client14.html +++ /dev/null @@ -1,14 +0,0 @@ - - - Test Client - - -
- - - - - - - - diff --git a/test/spec/TestClientSpec.hs b/test/spec/TestClientSpec.hs --- a/test/spec/TestClientSpec.hs +++ b/test/spec/TestClientSpec.hs @@ -35,14 +35,32 @@ 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" +scuShouldBe :: String -> [String] -> WD () +scuShouldBe ident items = do + d <- findElem $ ById $ T.pack ident 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) + forM_ (zip lis items) $ \(li,i) -> + getText li `shouldReturn` T.pack i +scuSingleShouldBe :: [String] -> WD () +scuSingleShouldBe = scuShouldBe "should-component-update-single" + +scuPairShouldBe :: [String] -> WD () +scuPairShouldBe = scuShouldBe "should-component-update-pair" + +scuTripleShouldBe :: [String] -> WD () +scuTripleShouldBe = scuShouldBe "should-component-update-triple" + +scuSingleLogMsg :: String -> String -> [String] +scuSingleLogMsg current new = ["Component will update single", "current props: " ++ current, "new props: " ++ new] + +scuPairLogMsg :: String -> String -> [String] +scuPairLogMsg current new = ["Component will update for pair input view", "current props: " ++ current, "new props: " ++ new] + +scuTripleLogMsg :: String -> String -> [String] +scuTripleLogMsg current new = ["Component will update for triple input view", "current props: " ++ current, "new props: " ++ new] + intlSpanShouldBe :: String -> String -> WD () intlSpanShouldBe ident txt = do e <- findElem (ById $ T.pack ident) @@ -62,11 +80,7 @@ y' = show y spec :: Spec -spec = do - describe "React 0.13" $ testClientSpec "test-client13.html" - describe "React 0.14" $ do - testClientSpec "test-client14.html" - intlSpec "test-client14.html" +spec = testClientSpec "test-client.html" testClientSpec :: String -> Spec testClientSpec filename = session " for the test client" $ using Chrome $ do @@ -95,7 +109,7 @@ [keydown, evt, keyEvt, modState, target, curTarget] <- loadLog keydown `shouldBe` "keydown" evt `shouldBeEvent` ("keydown", True, 3) - keyEvt `shouldBe` "(False,0,False,\"Unidentified\",88,\"\",0,False,False,False,88)" + keyEvt `shouldBe` "(False,0,False,\"Unidentified\",88,Nothing,0,False,False,False,88)" modState `shouldBe` "alt modifier: False" target `shouldBe` "keyinput" curTarget `shouldBe` "keyinput" @@ -104,9 +118,9 @@ findElem (ById "keyinput") >>= sendKeys "\xE00Ar" -- send Alt-r -- generates two events, one for alt, one for r [_, _, keyEvt, modState, _, _, _, _, keyEvt2, modState2, _, _] <- loadLog - keyEvt `shouldBe` "(True,0,False,\"Alt\",18,\"\",0,False,False,False,18)" + keyEvt `shouldBe` "(True,0,False,\"Alt\",18,Nothing,0,False,False,False,18)" modState `shouldBe` "alt modifier: True" - keyEvt2 `shouldBe` "(True,0,False,\"Unidentified\",82,\"\",0,False,False,False,82)" + keyEvt2 `shouldBe` "(True,0,False,\"Unidentified\",82,Nothing,0,False,False,False,82)" modState2 `shouldBe` "alt modifier: True" it "processes a click event" $ runWD $ do @@ -218,117 +232,195 @@ 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 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"] + it "renders a callback returning a view" $ runWD $ do + e <- findElem $ ById "callback-view-props-test" + getText e `shouldReturn` "Props are 5 and Hello World" 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 "has the initial data" $ runWD $ do + scuSingleShouldBe ["1Quick Ben", "5Karsa", "9Anomander Rake"] + scuPairShouldBe ["1Quick Ben2Whiskeyjack", "5Karsa6Tehol", "9Anomander Rake10Iskaral Pust"] + scuTripleShouldBe ["1Quick Ben2Whiskeyjack3Fiddler", "5Karsa6Tehol7Tayschrenn", "9Anomander Rake10Iskaral Pust11Dujek"] it "does not update when no change to data" $ runWD $ do findElem (ById "no-change-scu") >>= click - scuShouldBe [(2, "Hello"), (2, "World"), (3, "!!!")] + scuSingleShouldBe ["1Quick Ben", "5Karsa", "9Anomander Rake"] + scuPairShouldBe ["1Quick Ben2Whiskeyjack", "5Karsa6Tehol", "9Anomander Rake10Iskaral Pust"] + scuTripleShouldBe ["1Quick Ben2Whiskeyjack3Fiddler", "5Karsa6Tehol7Tayschrenn", "9Anomander Rake10Iskaral Pust11Dujek"] 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 !!!" - ] + describe "Changing the first scu" $ do + it "increments just the head of the list without re-rendering all entries" $ runWD $ do + findElem (ById "increment-first-scuSCU1") >>= click + scuSingleShouldBe ["2Quick Ben", "5Karsa", "9Anomander Rake"] + scuPairShouldBe ["2Quick Ben2Whiskeyjack", "5Karsa6Tehol", "9Anomander Rake10Iskaral Pust"] + scuTripleShouldBe ["2Quick Ben2Whiskeyjack3Fiddler", "5Karsa6Tehol7Tayschrenn", "9Anomander Rake10Iskaral Pust11Dujek"] + loadLog `shouldReturn` concat + [ scuSingleLogMsg "1 Quick Ben" + "2 Quick Ben" + , scuPairLogMsg "1 Quick Ben 2 Whiskeyjack" + "2 Quick Ben 2 Whiskeyjack" + , scuTripleLogMsg "1 Quick Ben 2 Whiskeyjack 3 Fiddler" + "2 Quick Ben 2 Whiskeyjack 3 Fiddler" + ] - {- - 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 "increments all entries" $ runWD $ do + findElem (ById "change-all-scu-SCU1") >>= click + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] + scuPairShouldBe ["3Quick Ben2Whiskeyjack", "6Karsa6Tehol", "10Anomander Rake10Iskaral Pust"] + scuTripleShouldBe ["3Quick Ben2Whiskeyjack3Fiddler", "6Karsa6Tehol7Tayschrenn", "10Anomander Rake10Iskaral Pust11Dujek"] + loadLog `shouldReturn` concat + [ scuSingleLogMsg "2 Quick Ben" + "3 Quick Ben" + , scuSingleLogMsg "5 Karsa" + "6 Karsa" + , scuSingleLogMsg "9 Anomander Rake" + "10 Anomander Rake" + , scuPairLogMsg "2 Quick Ben 2 Whiskeyjack" + "3 Quick Ben 2 Whiskeyjack" + , scuPairLogMsg "5 Karsa 6 Tehol" + "6 Karsa 6 Tehol" + , scuPairLogMsg "9 Anomander Rake 10 Iskaral Pust" + "10 Anomander Rake 10 Iskaral Pust" + , scuTripleLogMsg "2 Quick Ben 2 Whiskeyjack 3 Fiddler" + "3 Quick Ben 2 Whiskeyjack 3 Fiddler" + , scuTripleLogMsg "5 Karsa 6 Tehol 7 Tayschrenn" + "6 Karsa 6 Tehol 7 Tayschrenn" + , scuTripleLogMsg "9 Anomander Rake 10 Iskaral Pust 11 Dujek" + "10 Anomander Rake 10 Iskaral Pust 11 Dujek" + ] - 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" + describe "Changing the second scu" $ do - 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+1) ++ " days ago") + it "increments just the head of the list without re-rendering all entries" $ runWD $ do + findElem (ById "increment-first-scuSCU2") >>= click + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] -- unchanged + scuPairShouldBe ["3Quick Ben3Whiskeyjack", "6Karsa6Tehol", "10Anomander Rake10Iskaral Pust"] + scuTripleShouldBe ["3Quick Ben3Whiskeyjack3Fiddler", "6Karsa6Tehol7Tayschrenn", "10Anomander Rake10Iskaral Pust11Dujek"] + loadLog `shouldReturn` concat + [ scuPairLogMsg "3 Quick Ben 2 Whiskeyjack" + "3 Quick Ben 3 Whiskeyjack" + , scuTripleLogMsg "3 Quick Ben 2 Whiskeyjack 3 Fiddler" + "3 Quick Ben 3 Whiskeyjack 3 Fiddler" + ] - 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." + it "increments all entries" $ runWD $ do + findElem (ById "change-all-scu-SCU2") >>= click + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] -- unchanged + scuPairShouldBe ["3Quick Ben4Whiskeyjack", "6Karsa7Tehol", "10Anomander Rake11Iskaral Pust"] + scuTripleShouldBe ["3Quick Ben4Whiskeyjack3Fiddler", "6Karsa7Tehol7Tayschrenn", "10Anomander Rake11Iskaral Pust11Dujek"] + loadLog `shouldReturn` concat + [ scuPairLogMsg "3 Quick Ben 3 Whiskeyjack" + "3 Quick Ben 4 Whiskeyjack" + , scuPairLogMsg "6 Karsa 6 Tehol" + "6 Karsa 7 Tehol" + , scuPairLogMsg "10 Anomander Rake 10 Iskaral Pust" + "10 Anomander Rake 11 Iskaral Pust" + , scuTripleLogMsg "3 Quick Ben 3 Whiskeyjack 3 Fiddler" + "3 Quick Ben 4 Whiskeyjack 3 Fiddler" + , scuTripleLogMsg "6 Karsa 6 Tehol 7 Tayschrenn" + "6 Karsa 7 Tehol 7 Tayschrenn" + , scuTripleLogMsg "10 Anomander Rake 10 Iskaral Pust 11 Dujek" + "10 Anomander Rake 11 Iskaral Pust 11 Dujek" + ] - "f-msg-with-trans" `intlSpanShouldBe` "message from translation xxx" + describe "Changing the third scu" $ do - 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" + it "increments just the head of the list without re-rendering all entries" $ runWD $ do + findElem (ById "increment-first-scuSCU3") >>= click + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] -- unchanged + scuPairShouldBe ["3Quick Ben4Whiskeyjack", "6Karsa7Tehol", "10Anomander Rake11Iskaral Pust"] -- unchanged + scuTripleShouldBe ["3Quick Ben4Whiskeyjack4Fiddler", "6Karsa7Tehol7Tayschrenn", "10Anomander Rake11Iskaral Pust11Dujek"] + loadLog `shouldReturn` concat + [ scuTripleLogMsg "3 Quick Ben 4 Whiskeyjack 3 Fiddler" + "3 Quick Ben 4 Whiskeyjack 4 Fiddler" + ] - 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" - it "displays formatted properties" $ runWD $ do - "f-number-prop" `intlPlaceholderShouldBe` "123,456" - "f-date-prop" `intlPlaceholderShouldBe` "7/20/1969" - "f-time-prop" `intlPlaceholderShouldBe` "Jul 19, 69, 4 PM" - "f-plural-prop" `intlPlaceholderShouldBe` "other" - "f-msg-prop" `intlPlaceholderShouldBe` "Neil Armstrong took 100 photos" - "f-msg-prop-with-descr" `intlPlaceholderShouldBe` "Neil Armstrong took 0 photos" + it "increments all entries" $ runWD $ do + findElem (ById "change-all-scu-SCU3") >>= click + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] -- unchanged + scuPairShouldBe ["3Quick Ben4Whiskeyjack", "6Karsa7Tehol", "10Anomander Rake11Iskaral Pust"] -- unchanged + scuTripleShouldBe ["3Quick Ben4Whiskeyjack5Fiddler", "6Karsa7Tehol8Tayschrenn", "10Anomander Rake11Iskaral Pust12Dujek"] + loadLog `shouldReturn` concat + [ scuTripleLogMsg "3 Quick Ben 4 Whiskeyjack 4 Fiddler" + "3 Quick Ben 4 Whiskeyjack 5 Fiddler" + , scuTripleLogMsg "6 Karsa 7 Tehol 7 Tayschrenn" + "6 Karsa 7 Tehol 8 Tayschrenn" + , scuTripleLogMsg "10 Anomander Rake 11 Iskaral Pust 11 Dujek" + "10 Anomander Rake 11 Iskaral Pust 12 Dujek" + ] + + describe "changing the fourth scu" $ do + + it "increments just the head of the list" $ runWD $ do + findElem (ById "increment-first-scuSCU4") >>= click + -- unchanged + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] -- unchanged + scuPairShouldBe ["3Quick Ben4Whiskeyjack", "6Karsa7Tehol", "10Anomander Rake11Iskaral Pust"] -- unchanged + scuTripleShouldBe ["3Quick Ben4Whiskeyjack5Fiddler", "6Karsa7Tehol8Tayschrenn", "10Anomander Rake11Iskaral Pust12Dujek"] + loadLog `shouldReturn` [] + + it "increments all entries" $ runWD $ do + findElem (ById "change-all-scu-SCU4") >>= click + -- unchanged + scuSingleShouldBe ["3Quick Ben", "6Karsa", "10Anomander Rake"] -- unchanged + scuPairShouldBe ["3Quick Ben4Whiskeyjack", "6Karsa7Tehol", "10Anomander Rake11Iskaral Pust"] -- unchanged + scuTripleShouldBe ["3Quick Ben4Whiskeyjack5Fiddler", "6Karsa7Tehol8Tayschrenn", "10Anomander Rake11Iskaral Pust12Dujek"] + loadLog `shouldReturn` [] + + describe "i18n" $ 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+1) ++ " 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" + + it "displays formatted properties" $ runWD $ do + "f-number-prop" `intlPlaceholderShouldBe` "123,456" + "f-date-prop" `intlPlaceholderShouldBe` "7/20/1969" + "f-time-prop" `intlPlaceholderShouldBe` "Jul 19, 69, 4 PM" + "f-plural-prop" `intlPlaceholderShouldBe` "other" + "f-msg-prop" `intlPlaceholderShouldBe` "Neil Armstrong took 100 photos" + "f-msg-prop-with-descr" `intlPlaceholderShouldBe` "Neil Armstrong took 0 photos" diff --git a/test/spec/stack.yaml b/test/spec/stack.yaml --- a/test/spec/stack.yaml +++ b/test/spec/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-5.6 +resolver: lts-6.1 packages: - '.'