git.iko.soy/reflex-dom
on develop help sign in
swap
2236067141 ahead, 0 behind
40 files changed+1269−326
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+47 LICENSE+12 README.md+9−9 cabal.project+10−1 cabal.project-nogtk+14 chrome-test-utils/LICENSE+1−1 chrome-test-utils/chrome-test-utils.cabal+1−1 chrome-test-utils/src/Test/Util/UnshareNetwork.hs+2−2 dep/reflex-platform/default.nix+1−6 dep/reflex-platform/github.json+4−3 dep/reflex-platform/thunk.nix+9 reflex-dom-core/ChangeLog.md+45−30 reflex-dom-core/LICENSE+1−1 reflex-dom-core/reflex-dom-core.cabal+43−21 reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+10−1 reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+2−1 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+72−21 reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+35−10 reflex-dom-core/src/Reflex/Dom/Main.hs+37−7 reflex-dom-core/src/Reflex/Dom/Prerender.hs+6−3 reflex-dom-core/src/Reflex/Dom/Widget/Input.hs+4−4 reflex-dom-core/src/Reflex/Dom/Widget/Lazy.hs+1−1 reflex-dom-core/src/Reflex/Dom/Widget/Resize.hs+4−4 reflex-dom-core/test/gc.hs+1−1 reflex-dom-core/test/hlint.hs+1−1 reflex-dom-core/test/hydration.hs+385−41 reflex-dom-test-selenium/CHANGELOG.md+5 reflex-dom-test-selenium/LICENSE+12 reflex-dom-test-selenium/Setup.hs+2 reflex-dom-test-selenium/add-overrides.nix+20 reflex-dom-test-selenium/reflex-dom-test-selenium.cabal+41 reflex-dom-test-selenium/src/Reflex/Dom/Test/Selenium.hs+249 reflex-dom/ChangeLog.md+17−1 reflex-dom/LICENSE+1−1 reflex-dom/benchmark.hs+2−1 reflex-dom/reflex-dom.cabal+68−22 release.nix+13−4 test/default.nix+10 test/prebuild.hs−127 test/reflex-dom-reexports.hs+72
.github/workflows/haskell.ymlnew file+47
@@ -0,0 +1,47 @@
1+name: github-action
2+
3+on: [push, pull_request]
4+
5+jobs:
6+ build:
7+ strategy:
8+ matrix:
9+ ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
10+ os: ['ubuntu-latest', 'macos-latest']
11+ exclude:
12+ # There are some linker warnings in 802 on darwin that
13+ # cause compilation to fail
14+ # See https://github.com/NixOS/nixpkgs/issues/25139
15+ - ghc: '8.0.2'
16+ os: 'macos-latest'
17+ runs-on: ${{ matrix.os }}
18+
19+ name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
20+ steps:
21+ - uses: actions/checkout@v2
22+ - uses: actions/setup-haskell@v1
23+ with:
24+ ghc-version: ${{ matrix.ghc }}
25+ - name: Cache
26+ uses: actions/cache@v1
27+ env:
28+ cache-name: cache-cabal
29+ with:
30+ path: ~/.cabal
31+ key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
32+ restore-keys: |
33+ ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
34+ ${{ runner.os }}-${{ matrix.ghc }}-build-
35+ ${{ runner.os }}-${{ matrix.ghc }}-
36+ ${{ runner.os }}
37+
38+ - name: Set up cabal project file to avoid webkit2gtk
39+ run: cp cabal.project-nogtk cabal.project
40+ - name: Install dependencies
41+ run: |
42+ cabal update
43+ cabal build --only-dependencies --enable-tests --enable-benchmarks all
44+ - name: Build
45+ run: cabal build --enable-tests --enable-benchmarks all
46+ - name: Run tests
47+ run: cabal test all
LICENSEnew file+12
@@ -0,0 +1,12 @@
1+Copyright (c) 2020, Obsidian Systems LLC
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5+
6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7+
8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9+
10+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+
12+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+9−9
@@ -1,21 +1,21 @@
11## [Reflex-DOM](https://reflex-frp.org)
22
3−[![Hackage](https://img.shields.io/hackage/v/reflex-dom.svg)](http://hackage.haskell.org/package/reflex-dom)
3+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-dom.svg)](https://hackage.haskell.org/package/reflex-dom) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex-dom/badge)](https://matrix.hackage.haskell.org/#/package/reflex-dom) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex-dom/blob/master/LICENSE)
44
5−### A Framework for Functional Reactive Web Apps in Haskell
5+Web applications without callbacks or side-effects. Reflex-DOM brings the power of [Functional Reactive Programming (FRP)](https://wiki.haskell.org/Functional_Reactive_Programming) to the web. Build [HTML](https://developer.mozilla.org/en-US/docs/Web/HTML) and other [Document Object Model (DOM)](https://developer.mozilla.org/en-US/docs/Web/API/Document_Object_Model) data with a pure functional interface.
66
7−Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/reflex-frp/reflex).
8−
9−A summary of Reflex-DOM functions is available in the [quick reference](Quickref.md).
7+Reflex-DOM is a framework for building web applications in [Haskell](https://www.haskell.org/), based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/reflex-frp/reflex).
108
119**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
1210
1311### Additional resources
14−[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
15−
16−[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
1712
18−[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
13+* [Official Website](https://reflex-frp.org/)
14+* [Quick Reference](Quickref.md)
15+* [Obelisk](https://github.com/obsidiansystems/obelisk#obelisk): A framework built on Reflex and Reflex-DOM for functional reactive web and mobile applications, with batteries included.
16+* [Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
17+* [/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
18+* [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
1919
2020### Hacking
2121
cabal.project+10−1
@@ -1 +1,10 @@
1−packages: reflex-dom-core, reflex-dom
1+packages:
2+ reflex-dom-core/
3+ reflex-dom/
4+ chrome-test-utils/
5+ reflex-dom-test-selenium/
6+
7+source-repository-package
8+ type: git
9+ location: https://github.com/dfordivam/hspec-webdriver-clone
10+ tag: 0d748b7bb7cd74dce0a55a1ec86b01dbb8a71cd8
cabal.project-nogtknew file+14
@@ -0,0 +1,14 @@
1+packages:
2+ reflex-dom-core/
3+ reflex-dom/
4+
5+package reflex-dom-core
6+ flags: -hydration-tests -gc-tests
7+
8+package reflex-dom
9+ flags: +use-warp -webkit2gtk
10+
11+source-repository-package
12+ type: git
13+ location: https://github.com/dfordivam/hspec-webdriver-clone
14+ tag: 0d748b7bb7cd74dce0a55a1ec86b01dbb8a71cd8
chrome-test-utils/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2019, Obsidian Systems LLC
1+Copyright (c) 2020, Obsidian Systems LLC
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
chrome-test-utils/chrome-test-utils.cabal+1−1
@@ -1,5 +1,5 @@
11Name: chrome-test-utils
2−Version: 0.4
2+Version: 0.5
33Synopsis: Utilities to write headless Chromium tests
44License: BSD3
55License-file: LICENSE
chrome-test-utils/src/Test/Util/UnshareNetwork.hs+2−2
@@ -4,8 +4,8 @@ import System.Linux.Namespaces
44import System.Posix
55import System.Process
66
7−unshareNetork :: IO ()
8−unshareNetork = do
7+unshareNetwork :: IO ()
8+unshareNetwork = do
99 uid <- getEffectiveUserID
1010 unshare [User, Network]
1111 writeUserMappings Nothing [UserMapping 0 uid 1]
dep/reflex-platform/default.nix+1−6
@@ -1,7 +1,2 @@
11# DO NOT HAND-EDIT THIS FILE
2−import ((import <nixpkgs> {}).fetchFromGitHub (
3− let json = builtins.fromJSON (builtins.readFile ./github.json);
4− in { inherit (json) owner repo rev sha256;
5− private = json.private or false;
6− }
7−))
2+import (import ./thunk.nix)
dep/reflex-platform/github.json+4−3
@@ -1,7 +1,8 @@
11{
22 "owner": "reflex-frp",
33 "repo": "reflex-platform",
4− "branch": "master",
5− "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
6− "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
4+ "branch": "aa-bump-some",
5+ "private": false,
6+ "rev": "fd5acecb50474f795734db9fb924cc3b2fd2b508",
7+ "sha256": "0wsdd67g42klsf9n3pxb3pndjdz36nzf8gp7pfm8j6nyyy2qribk"
78}
dep/reflex-platform/thunk.nixnew file+9
@@ -0,0 +1,9 @@
1+# DO NOT HAND-EDIT THIS FILE
2+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3+ if !fetchSubmodules && !private then builtins.fetchTarball {
4+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5+ } else (import <nixpkgs> {}).fetchFromGitHub {
6+ inherit owner repo rev sha256 fetchSubmodules private;
7+ };
8+ json = builtins.fromJSON (builtins.readFile ./github.json);
9+in fetch json
reflex-dom-core/ChangeLog.md+45−30
@@ -1,51 +1,66 @@
11# Revision history for reflex-dom-core
22
3−## Unreleased
3+## 0.6.2.1
44
5+* Fix hlint complaints with newer GHC.
6+
7+## 0.6.2.0
8+
9+* ([#400](https://github.com/reflex-frp/reflex-dom/pull/400/files)) Set value of input elements in static renderer
10+
11+## 0.6.1.0
12+
13+* Bump version bounds
14+* Update for new dependent-map and dependent-sum version (after the "some" package split)
15+* Add `MonadAtomicRef` instance for `UnrunnableT`
16+* Fix ([#467](https://github.com/reflex-frp/reflex-dom/issues/467)): Prevent multiple firings of XHR response event
17+* Updates for GHC 8.10
18+* Move `HasSetValue` from Reflex.Dom.Widget.Input to Reflex.Dom.Builder.Class and add an instance for `TextAreaElementConfig`
19+* Add `now` to the `MonadHold` instance for `UnrunnableT`
20+
21+
22+## 0.6.0.0
23+
24+* ([#375](https://github.com/reflex-frp/reflex-dom/pull/375)) **(Breaking change)** Expose resized dimensions from `resizeDetector`, `resizeDetectorWithStyle`, and `resizeDetectorWithAttrs` from `Reflex.Dom.Widget.Resize`.
25+* ([#374](https://github.com/reflex-frp/reflex-dom/pull/374)) **(Breaking change)** Provide text clipboard data as value of `Paste` event.
26+* ([#348](https://github.com/reflex-frp/reflex-dom/pull/348)) **(Breaking change)** Make XHR response headers case insensitive by changing `_xhrResponse_headers :: Map Text Text` to `_xhrResponse_headers :: Map (CI Text) Text`.
27+* ([#225](https://github.com/reflex-frp/reflex-dom/pull/225)) **(Breaking change)** Add a functional dependency to `HasDomEvent`.
28+* ([#342](https://github.com/reflex-frp/reflex-dom/issues/342)) **(Breaking change)** The mouse wheel event is now a `WheelEventResult` rather than `()`. This provides information about the wheel's motion beyond the fact that it merely moved.
529* ([#353](https://github.com/reflex-frp/reflex-dom/pull/353)) Support GHC 8.8.
630* ([#358](https://github.com/reflex-frp/reflex-dom/pull/358)) Fix attribute support for explicitly namespaced elements.
731* ([#363](https://github.com/reflex-frp/reflex-dom/pull/363)) Remove deprecation warnings for the following widgets in
832 `Reflex.Dom.Widget.Basic`:
9−
10− * `Link`
11− * `button`
12− * `dtdd`
13− * `linkClass`
14− * `link`
15− * `tabDisplay`
16− * `tableDynAttr`
33+ * `Link`
34+ * `button`
35+ * `dtdd`
36+ * `linkClass`
37+ * `link`
38+ * `tabDisplay`
39+ * `tableDynAttr`
1740* ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)) Fix bug in hydration causing the JavaScript to crash when dealing with unexpected HTML.
41+* ([#310](https://github.com/reflex-frp/reflex-dom/issues/310)) Fix the static rendering of which dropdown value is selected.
1842* ([#364](https://github.com/reflex-frp/reflex-dom/pull/364)) Export attributes used for controlling hydration at the element level:
1943 * "data-ssr" is now available as `Reflex.Dom.Builder.Immediate.hydratableAttribute`.
2044 * "data-hydration-skip" is now available as `Reflex.Dom.Builder.Immediate.skipHydrationAttribute`.
21−* ([#348](https://github.com/reflex-frp/reflex-dom/pull/348)) **(Breaking change)** Make XHR response headers case insensitive by changing `_xhrResponse_headers :: Map Text Text` to `_xhrResponse_headers :: Map (CI Text) Text`.
22−* ([#225](https://github.com/reflex-frp/reflex-dom/pull/225)) **(Breaking change)** Add a functional dependency to `HasDomEvent`.
2345* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
2446
25−
2647## 0.5.3
2748
2849* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:
29−
30− * `Link`
31− * `button`
32− * `dtdd`
33− * `linkClass`
34− * `link`
35− * `tabDisplay`
36− * `tableDynAttr`
50+ * `Link`
51+ * `button`
52+ * `dtdd`
53+ * `linkClass`
54+ * `link`
55+ * `tabDisplay`
56+ * `tableDynAttr`
3757
3858 And in `Reflex.Dom.Widget.Input`:
39−
40− * `TextInput`
41− * `TextAreaConfig`
42− * `CheckboxConfig`
43− * `FileInput`
44−
45− * Add `< 0.7` upper bound for reflex
46−
47−* *(Breaking change)* The mouse wheel event now is a `WheelEventResult` rather than `()`.
48− This provides information about the wheel's motion beyond the fact that it merely moved.
59+ * `TextInput`
60+ * `TextAreaConfig`
61+ * `CheckboxConfig`
62+ * `FileInput`
63+* Add `< 0.7` upper bound for `reflex`.
4964
5065## 0.5.2
5166
reflex-dom-core/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015, Obsidian Systems LLC
1+Copyright (c) 2020, Obsidian Systems LLC
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
reflex-dom-core/reflex-dom-core.cabal+43−21
@@ -1,7 +1,18 @@
1+cabal-version: 1.24
12Name: reflex-dom-core
2−Version: 0.5.3
3+Version: 0.6.2.1
34Synopsis: Functional Reactive Web Apps with Reflex
4−Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
5+Description:
6+ Web applications without callbacks or side-effects.
7+ Reflex-DOM brings the power of functional reactive programming (FRP) to the web.
8+ Build HTML and other Document Object Model (DOM) data with a pure functional interface.
9+ .
10+ Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.
11+ .
12+ The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the
13+ correct set of dependencies for each target platform (GHCJS, WebKitGTK, WASM, mobile, etc.).
14+ Libraries should depend on @reflex-dom-core@ and executables will usually depend on @reflex-dom@.
15+ All of @reflex-dom-core@'s modules are re-exported by @reflex-dom@.
516License: BSD3
617License-file: LICENSE
718Author: Ryan Trinkle
@@ -9,7 +20,6 @@ Maintainer: ryan.trinkle@gmail.com
920Stability: Experimental
1021Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
1122Build-type: Simple
12−Cabal-version: >=1.9.2
1323-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
1424extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs
1525 src-ghcjs/Foreign/JavaScript/Internal/Utils.hs
@@ -44,22 +54,32 @@ flag split-these
4454 manual: False
4555 default: True
4656
57+flag hydration-tests
58+ description: Whether to run the hydration tests (currently only available on linux)
59+ default: True
60+ manual: True
61+
62+flag gc-tests
63+ description: Whether to run the gc tests (currently only available on linux)
64+ default: True
65+ manual: True
66+
4767library
4868 hs-source-dirs: src
4969 build-depends:
50− aeson >= 0.8 && < 1.5,
51− base >= 4.7 && < 4.14,
70+ aeson >= 0.8 && < 1.6,
71+ base >= 4.7 && < 4.15,
5272 bifunctors >= 4.2 && < 6,
53− bimap >= 0.3 && < 0.4,
54− blaze-builder,
73+ bimap >= 0.3 && < 0.5,
74+ blaze-builder >= 0.4.1 && < 0.5,
5575 bytestring == 0.10.*,
5676 case-insensitive < 1.3,
5777 containers >= 0.6 && < 0.7,
58− constraints >= 0.9 && < 0.12,
78+ constraints >= 0.9 && < 0.13,
5979 contravariant >= 1.4 && < 1.6,
6080 data-default >= 0.5 && < 0.8,
61− dependent-map >= 0.3 && < 0.4,
62− dependent-sum >= 0.6 && < 0.7,
81+ dependent-map >= 0.3 && < 0.5,
82+ dependent-sum >= 0.6 && < 0.8,
6383 dependent-sum-template >= 0.1 && < 0.2,
6484 directory >= 1.2 && < 1.4,
6585 exception-transformers == 0.4.*,
@@ -71,9 +91,9 @@ library
7191 monad-control >= 1.0.1 && < 1.1,
7292 mtl >= 2.1 && < 2.3,
7393 primitive >= 0.5 && < 0.8,
74− random,
94+ random >= 1.1 && < 1.2,
7595 ref-tf == 0.4.*,
76− reflex >= 0.6.2 && < 0.8,
96+ reflex >= 0.8 && < 0.9,
7797 semigroups >= 0.16 && < 0.20,
7898 stm >= 2.4 && < 2.6,
7999 text == 1.2.*,
@@ -94,7 +114,7 @@ library
94114 if flag(split-these)
95115 build-depends:
96116 semialign >= 1 && < 1.2,
97− these >= 1 && < 1.1
117+ these >= 1 && < 1.2
98118 else
99119 build-depends:
100120 these >= 0.4 && < 0.9
@@ -133,6 +153,7 @@ library
133153 Reflex.Dom.Xhr.ResponseType
134154 Reflex.Dom.Xhr.Exception
135155
156+ default-language: Haskell98
136157 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively
137158 ghc-prof-options: -fprof-auto
138159
@@ -147,22 +168,21 @@ library
147168
148169 if flag(use-template-haskell)
149170 build-depends:
150− dependent-sum >= 0.6,
151171 dependent-sum-template >= 0.1 && < 0.2,
152− template-haskell
172+ template-haskell >= 2.12.0 && < 2.17
153173 other-extensions: TemplateHaskell
154174 cpp-options: -DUSE_TEMPLATE_HASKELL
155175 other-modules:
156176 Reflex.Dom.Builder.Class.TH
157− else
158− build-depends:
159− dependent-sum == 0.6.*
160177
161178test-suite hlint
162− build-depends: base, hlint
179+ build-depends:
180+ base,
181+ hlint >= 2.0 && < 4.0
163182 hs-source-dirs: test
164183 main-is: hlint.hs
165184 type: exitcode-stdio-1.0
185+ default-language: Haskell98
166186
167187test-suite hydration
168188 build-depends: base
@@ -209,7 +229,8 @@ test-suite hydration
209229 ghc-prof-options: -fprof-auto -optP-DPROFILING
210230 main-is: hydration.hs
211231 type: exitcode-stdio-1.0
212− if !os(linux) || !arch(x86_64) || flag(profile-reflex)
232+ default-language: Haskell98
233+ if !os(linux) || !arch(x86_64) || flag(profile-reflex) || !flag(hydration-tests)
213234 buildable: False
214235
215236-- broken test on base 4.11 & ghc 8.4.3
@@ -228,7 +249,8 @@ test-suite gc
228249 ghc-prof-options: -fprof-auto -optP-DPROFILING
229250 main-is: gc.hs
230251 type: exitcode-stdio-1.0
231− if !os(linux) || !arch(x86_64)
252+ default-language: Haskell98
253+ if !os(linux) || !arch(x86_64) || !flag(gc-tests)
232254 buildable: False
233255
234256source-repository head
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+10−1
@@ -9,11 +9,12 @@
99{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1010#if !MIN_VERSION_base(4,9,0)
1111{-# LANGUAGE ImpredicativeTypes #-}
12+#else
13+{-# LANGUAGE Rank2Types #-} -- Implied by ImpredicativeTypes
1214#endif
1315{-# LANGUAGE LambdaCase #-}
1416{-# LANGUAGE OverloadedStrings #-}
1517{-# LANGUAGE PolyKinds #-}
16−{-# LANGUAGE Rank2Types #-}
1718{-# LANGUAGE RecursiveDo #-}
1819{-# LANGUAGE ScopedTypeVariables #-}
1920{-# LANGUAGE StandaloneDeriving #-}
@@ -744,3 +745,11 @@ instance HasDocument m => HasDocument (DynamicWriterT t w m)
744745instance HasDocument m => HasDocument (PostBuildT t m)
745746instance HasDocument m => HasDocument (RequesterT t request response m)
746747instance HasDocument m => HasDocument (QueryT t q m)
748+
749+class HasSetValue a where
750+ type SetValue a :: *
751+ setValue :: Lens' a (SetValue a)
752+
753+instance Reflex t => HasSetValue (TextAreaElementConfig er t m) where
754+ type SetValue (TextAreaElementConfig er t m) = Event t Text
755+ setValue = textAreaElementConfig_setValue
reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+2−1
@@ -14,6 +14,7 @@ import Data.GADT.Compare.TH
1414import Data.GADT.Compare
1515 (GOrdering(..), (:~:)(..), GEq(..), GCompare(..))
1616#endif
17+import Data.Text (Text)
1718
1819data EventTag
1920 = AbortTag
@@ -151,7 +152,7 @@ type family EventResultType (en :: EventTag) :: * where
151152 EventResultType 'BeforecopyTag = ()
152153 EventResultType 'CopyTag = ()
153154 EventResultType 'BeforepasteTag = ()
154− EventResultType 'PasteTag = ()
155+ EventResultType 'PasteTag = Maybe Text
155156 EventResultType 'ResetTag = ()
156157 EventResultType 'SearchTag = ()
157158 EventResultType 'SelectstartTag = ()
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+72−21
@@ -2,7 +2,6 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE ConstraintKinds #-}
44{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE DeriveFunctor #-}
65{-# LANGUAGE DeriveTraversable #-}
76{-# LANGUAGE EmptyDataDecls #-}
87{-# LANGUAGE FlexibleContexts #-}
@@ -49,6 +48,7 @@ module Reflex.Dom.Builder.Immediate
4948 , HydrationMode (..)
5049 , HydrationRunnerT (..)
5150 , runHydrationRunnerT
51+ , runHydrationRunnerTWithFailure
5252 , ImmediateDomBuilderT
5353 , runHydrationDomBuilderT
5454 , getHydrationMode
@@ -135,15 +135,18 @@ import Data.Functor.Compose
135135import Data.Functor.Constant
136136import Data.Functor.Misc
137137import Data.Functor.Product
138+import Data.GADT.Compare (GCompare)
138139import Data.IORef
139140import Data.IntMap.Strict (IntMap)
140141import Data.Maybe
141142import Data.Monoid ((<>))
142143import Data.Some (Some(..))
144+import Data.GADT.Compare (GCompare)
143145import Data.String (IsString)
144146import Data.Text (Text)
145147import Foreign.JavaScript.Internal.Utils
146148import Foreign.JavaScript.TH
149+import GHCJS.DOM.ClipboardEvent as ClipboardEvent
147150import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
148151import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
149152import GHCJS.DOM.EventM (EventM, event, on)
@@ -179,6 +182,7 @@ import qualified Data.IntMap.Strict as IntMap
179182import qualified Data.Map as Map
180183import qualified Data.Text as T
181184import qualified GHCJS.DOM as DOM
185+import qualified GHCJS.DOM.DataTransfer as DataTransfer
182186import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
183187import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
184188import qualified GHCJS.DOM.Element as Element
@@ -290,12 +294,21 @@ localRunner (HydrationRunnerT m) s parent = do
290294runHydrationRunnerT
291295 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
292296 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
293−runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
297+runHydrationRunnerT m = runHydrationRunnerTWithFailure m (pure ())
298+
299+{-# INLINABLE runHydrationRunnerTWithFailure #-}
300+runHydrationRunnerTWithFailure
301+ :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
302+ => HydrationRunnerT t m a -> IO () -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
303+runHydrationRunnerTWithFailure (HydrationRunnerT m) onFailure s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
294304 (a, s') <- runStateT m (HydrationState s False)
295305 traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
296306 when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."
307+ when (_hydrationState_failed s') $ liftIO onFailure
297308 pure a
298309
310+
311+
299312instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
300313 {-# INLINABLE newEventWithTrigger #-}
301314 newEventWithTrigger = lift . newEventWithTrigger
@@ -319,7 +332,7 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
319332-- done *before* the switchover to immediate mode - this is most likely some
320333-- form of 'hold' which we want to remove after hydration is done
321334{-# INLINABLE addHydrationStepWithSetup #-}
322−addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
335+addHydrationStepWithSetup :: MonadIO m => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
323336addHydrationStepWithSetup setup f = getHydrationMode >>= \case
324337 HydrationMode_Immediate -> pure ()
325338 HydrationMode_Hydrating -> do
@@ -924,14 +937,26 @@ inputElementInternal cfg = getHydrationMode >>= \case
924937 doc <- askDocument
925938 -- Expected initial value from config
926939 let v0 = _inputElementConfig_initialValue cfg
927− addHydrationStep $ do
940+ c0 = _inputElementConfig_initialChecked cfg
941+ valuesAtSwitchover = do
942+ v <- maybe (pure $ pure v0) (hold v0) (_inputElementConfig_setValue cfg)
943+ c <- maybe (pure $ pure c0) (hold c0) (_inputElementConfig_setChecked cfg)
944+ pure (v, c)
945+ addHydrationStepWithSetup valuesAtSwitchover $ \(switchoverValue', switchoverChecked') -> do
946+ switchoverValue <- sample switchoverValue'
947+ switchoverChecked <- sample switchoverChecked'
928948 domElement <- liftIO $ readIORef domElementRef
929949 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
930950 getValue = Input.getValue domInputElement
931− -- The browser might have messed with the value, or the user could have
932− -- altered it before activation, so we set it if it isn't what we expect
933− liftJSM getValue >>= \v0' -> do
934− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
951+ -- When the value has been updated by setValue before switchover, we must
952+ -- send an update here to remain in sync. This is because the later
953+ -- requestDomAction based on the setValue event will not capture events
954+ -- happening before postBuild, because this code runs after switchover.
955+ when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue
956+ -- The user could have altered the value before switchover. This must be
957+ -- triggered after the setValue one in order for the events to be in the
958+ -- correct order.
959+ liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue
935960 -- Watch for user interaction and trigger event accordingly
936961 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
937962 for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
@@ -945,7 +970,17 @@ inputElementInternal cfg = getHydrationMode >>= \case
945970 ]
946971 liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
947972 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
948− Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
973+ -- When the checked state has been updated by setChecked before
974+ -- switchover, we must send an update here to remain in sync. This is
975+ -- because the later requestDomAction based on the setChecked event will not
976+ -- capture events happening before postBuild, because this code runs after
977+ -- switchover.
978+ when (c0 /= switchoverChecked) $ liftIO $ triggerCheckedChangedBySetChecked switchoverChecked
979+ -- The user could have clicked the checkbox before switchover, we only
980+ -- detect cases where they flipped the state. This must be triggered after
981+ -- the setValue one in order for the events to be in the correct order.
982+ liftJSM (Input.getChecked domInputElement) >>= \realChecked -> when (realChecked /= switchoverChecked) $
983+ liftIO $ triggerCheckedChangedByUI realChecked
949984 _ <- liftJSM $ domInputElement `on` Events.click $ do
950985 liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
951986 for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
@@ -958,7 +993,7 @@ inputElementInternal cfg = getHydrationMode >>= \case
958993 let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
959994 liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
960995 return ()
961− checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
996+ checked' <- holdDyn c0 $ leftmost
962997 [ checkedChangedBySetChecked
963998 , checkedChangedByUI
964999 ]
@@ -1030,14 +1065,21 @@ textAreaElementInternal cfg = getHydrationMode >>= \case
10301065 doc <- askDocument
10311066 -- Expected initial value from config
10321067 let v0 = _textAreaElementConfig_initialValue cfg
1033− addHydrationStep $ do
1068+ valueAtSwitchover = maybe (pure $ pure v0) (hold v0) (_textAreaElementConfig_setValue cfg)
1069+ addHydrationStepWithSetup valueAtSwitchover $ \switchoverValue' -> do
1070+ switchoverValue <- sample switchoverValue'
10341071 domElement <- liftIO $ readIORef domElementRef
10351072 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
10361073 getValue = TextArea.getValue domTextAreaElement
1037− -- The browser might have messed with the value, or the user could have
1038− -- altered it before activation, so we set it if it isn't what we expect
1039− liftJSM getValue >>= \v0' -> do
1040− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1074+ -- When the value has been updated by setValue before switchover, we must
1075+ -- send an update here to remain in sync. This is because the later
1076+ -- requestDomAction based on the setValue event will not capture events
1077+ -- happening before postBuild, because this code runs after switchover.
1078+ when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue
1079+ -- The user could have altered the value before switchover. This must be
1080+ -- triggered after the setValue one in order for the events to be in the
1081+ -- correct order.
1082+ liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue
10411083 -- Watch for user interaction and trigger event accordingly
10421084 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
10431085 for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
@@ -1630,7 +1672,7 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ra
16301672
16311673{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
16321674traverseDMapWithKeyWithAdjust'
1633− :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1675+ :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
16341676 => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
16351677 -> DMap k v
16361678 -> Event t (PatchDMap k v)
@@ -1750,7 +1792,7 @@ hoistTraverseWithKeyWithAdjust
17501792 ::
17511793 ( Adjustable t m
17521794 , MonadHold t m
1753− , DMap.GCompare k
1795+ , GCompare k
17541796 , MonadIO m
17551797 , MonadJSM m
17561798 , PrimMonad m
@@ -1834,14 +1876,14 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
18341876 getHydrationMode >>= \case
18351877 HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
18361878 dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1837− phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1879+ phs <- sequenceA $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
18381880 liftIO $ writeIORef placeholders $! phs
18391881 insertAfterPreviousNode lastPlaceholder
18401882 HydrationMode_Immediate -> do
18411883 let activate i = do
18421884 append $ toNode $ _traverseChildImmediate_fragment i
18431885 pure $ _traverseChildImmediate_placeholder i
1844− phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1886+ phs <- sequenceA $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
18451887 liftIO $ writeIORef placeholders $! phs
18461888 append $ toNode lastPlaceholder
18471889 requestDomAction_ $ ffor children' $ \p -> do
@@ -2255,7 +2297,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22552297 Beforecopy -> return ()
22562298 Copy -> return ()
22572299 Beforepaste -> return ()
2258− Paste -> return ()
2300+ Paste -> getPasteData
22592301 Reset -> return ()
22602302 Search -> return ()
22612303 Selectstart -> return ()
@@ -2305,7 +2347,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
23052347 Beforecopy -> return ()
23062348 Copy -> return ()
23072349 Beforepaste -> return ()
2308− Paste -> return ()
2350+ Paste -> getPasteData
23092351 Reset -> return ()
23102352 Search -> return ()
23112353 Selectstart -> return ()
@@ -2582,6 +2624,15 @@ getMouseEventCoords = do
25822624 e <- event
25832625 bisequence (getClientX e, getClientY e)
25842626
2627+{-# INLINABLE getPasteData #-}
2628+getPasteData :: EventM e ClipboardEvent (Maybe Text)
2629+getPasteData = do
2630+ e <- event
2631+ mdt <- ClipboardEvent.getClipboardData e
2632+ case mdt of
2633+ Nothing -> return Nothing
2634+ Just dt -> Just <$> DataTransfer.getData dt ("text" :: Text)
2635+
25852636{-# INLINABLE getTouchEvent #-}
25862637getTouchEvent :: EventM e TouchEvent TouchEventResult
25872638getTouchEvent = do
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+35−10
@@ -37,6 +37,7 @@ import Data.IntMap (IntMap)
3737import qualified Data.IntMap as IntMap
3838import qualified Data.Map as Map
3939import Data.Map.Misc (applyMap)
40+import Data.Maybe (fromMaybe)
4041import Data.Monoid ((<>))
4142import qualified Data.Set as Set
4243import Data.Text (Text)
@@ -273,7 +274,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
273274 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5
274275 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape
275276 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8
276− modify . (:) =<< (\c -> "<!--" <> c <> "-->") <$> case mSetContents of
277+ (modify . (:)) . (\c -> "<!--" <> c <> "-->") =<< case mSetContents of
277278 Nothing -> return (pure (escape initialContents))
278279 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on
279280 return $ CommentNode ()
@@ -311,13 +312,32 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
311312 return (e, result)
312313 {-# INLINABLE inputElement #-}
313314 inputElement cfg = do
314− (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
315− let v0 = constDyn $ cfg ^. inputElementConfig_initialValue
316− let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked
315+ -- Tweak the config to update the "value" and "checked" attributes appropriately.
316+ -- TODO: warn upon overwriting values.
317+ let setInitialValue = Map.insert "value" (_inputElementConfig_initialValue cfg)
318+ setUpdatedValue updatedAttrs = case _inputElementConfig_setValue cfg of
319+ Nothing -> updatedAttrs
320+ Just e -> (Map.singleton "value" . Just <$> e) <> updatedAttrs
321+ setInitialChecked = case _inputElementConfig_initialChecked cfg of
322+ True -> Map.insert "checked" "checked"
323+ False -> id
324+ setUpdatedChecked updatedAttrs = case _inputElementConfig_setChecked cfg of
325+ Nothing -> updatedAttrs
326+ Just e -> (Map.singleton "checked" (Just "checked") <$ e) <> updatedAttrs
327+ adjustedConfig = _inputElementConfig_elementConfig cfg
328+ & elementConfig_initialAttributes %~ setInitialValue . setInitialChecked
329+ & elementConfig_modifyAttributes %~ setUpdatedValue . setUpdatedChecked
330+ (e, _result) <- element "input" adjustedConfig $ return ()
331+ v <- case _inputElementConfig_setValue cfg of
332+ Nothing -> pure $ constDyn (cfg ^. inputElementConfig_initialValue)
333+ Just ev -> holdDyn (cfg ^. inputElementConfig_initialValue) ev
334+ c <- case _inputElementConfig_setChecked cfg of
335+ Nothing -> pure $ constDyn $ _inputElementConfig_initialChecked cfg
336+ Just ev -> holdDyn (_inputElementConfig_initialChecked cfg) ev
317337 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
318338 return $ InputElement
319− { _inputElement_value = v0
320− , _inputElement_checked = c0
339+ { _inputElement_value = v
340+ , _inputElement_checked = c
321341 , _inputElement_checkedChange = never
322342 , _inputElement_input = never
323343 , _inputElement_hasFocus = hasFocus
@@ -327,12 +347,17 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
327347 }
328348 {-# INLINABLE textAreaElement #-}
329349 textAreaElement cfg = do
330− --TODO: Support setValue event
331− (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
332− let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue
350+ (e, _domElement) <- element "textarea" (_textAreaElementConfig_elementConfig cfg) $ do
351+ -- Set the initial value
352+ void $ textNode $ def
353+ & textNodeConfig_initialContents .~ _textAreaElementConfig_initialValue cfg
354+ & textNodeConfig_setContents .~ fromMaybe never (_textAreaElementConfig_setValue cfg)
355+ v <- case _textAreaElementConfig_setValue cfg of
356+ Nothing -> pure $ constDyn (cfg ^. textAreaElementConfig_initialValue)
357+ Just ev -> holdDyn (cfg ^. textAreaElementConfig_initialValue) ev
333358 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
334359 return $ TextAreaElement
335− { _textAreaElement_value = v0
360+ { _textAreaElement_value = v
336361 , _textAreaElement_input = never
337362 , _textAreaElement_hasFocus = hasFocus
338363 , _textAreaElement_element = e
reflex-dom-core/src/Reflex/Dom/Main.hs+37−7
@@ -5,7 +5,6 @@
55{-# LANGUAGE GADTs #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE NoMonomorphismRestriction #-}
8−{-# LANGUAGE PatternSynonyms #-}
98{-# LANGUAGE RankNTypes #-}
109{-# LANGUAGE RecursiveDo #-}
1110{-# LANGUAGE ScopedTypeVariables #-}
@@ -73,8 +72,14 @@ mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverActio
7372{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}
7473-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.
7574mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
76−mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do
77− runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do
75+mainHydrationWidgetWithSwitchoverAction' = mainHydrationWidgetWithSwitchoverActionWithFailure' (pure ())
76+
77+
78+{-# INLINABLE mainHydrationWidgetWithSwitchoverActionWithFailure' #-}
79+-- | Warning: `mainHydrationWidgetWithSwitchoverActionWithFaiilure'` is provided only as performance tweak. It is expected to disappear in future releases.
80+mainHydrationWidgetWithSwitchoverActionWithFailure' :: IO () -> JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
81+mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchoverAction head' body = do
82+ runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction $ \appendHead appendBody -> do
7883 appendHead head'
7984 appendBody body
8085
@@ -89,7 +94,21 @@ attachHydrationWidget
8994 -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
9095 )
9196 -> IO (a, FireCommand DomTimeline DomHost)
92−attachHydrationWidget switchoverAction jsSing w = do
97+attachHydrationWidget = attachHydrationWidgetWithFailure (pure ())
98+
99+{-# INLINABLE attachHydrationWidgetWithFailure #-}
100+attachHydrationWidgetWithFailure
101+ :: IO ()
102+ -> JSM ()
103+ -> JSContextSingleton ()
104+ -> ( Event DomTimeline ()
105+ -> IORef HydrationMode
106+ -> Maybe (IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())])
107+ -> EventChannel
108+ -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
109+ )
110+ -> IO (a, FireCommand DomTimeline DomHost)
111+attachHydrationWidgetWithFailure onFailure switchoverAction jsSing w = do
93112 hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating
94113 rootNodesRef <- liftIO $ newIORef []
95114 events <- newChan
@@ -105,7 +124,7 @@ attachHydrationWidget switchoverAction jsSing w = do
105124 rootNodes <- liftIO $ readIORef rootNodesRef
106125 let delayedAction = do
107126 for_ (reverse rootNodes) $ \(rootNode, runner) -> do
108− let hydrate = runHydrationRunnerT runner Nothing rootNode events
127+ let hydrate = runHydrationRunnerTWithFailure runner onFailure Nothing rootNode events
109128 void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing
110129 liftIO $ writeIORef hydrationMode HydrationMode_Immediate
111130 runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing
@@ -126,11 +145,22 @@ runHydrationWidgetWithHeadAndBody
126145 -> FloatingWidget () ()
127146 )
128147 -> JSM ()
129−runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
148+runHydrationWidgetWithHeadAndBody = runHydrationWidgetWithHeadAndBodyWithFailure (pure ())
149+
150+{-# INLINABLE runHydrationWidgetWithHeadAndBodyWithFailure #-}
151+runHydrationWidgetWithHeadAndBodyWithFailure
152+ :: IO ()
153+ -> JSM ()
154+ -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head" --TODO: test invoking this more than once
155+ -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body" --TODO: test invoking this more than once
156+ -> FloatingWidget () ()
157+ )
158+ -> JSM ()
159+runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
130160 globalDoc <- currentDocumentUnchecked
131161 headElement <- getHeadUnchecked globalDoc
132162 bodyElement <- getBodyUnchecked globalDoc
133− (events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
163+ (events, fc) <- liftIO . attachHydrationWidgetWithFailure onFailure switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
134164 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
135165 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
136166 hydrateDom n w = do
reflex-dom-core/src/Reflex/Dom/Prerender.hs+6−3
@@ -24,7 +24,7 @@ module Reflex.Dom.Prerender
2424
2525import Control.Monad.Primitive (PrimMonad(..))
2626import Control.Monad.Reader
27−import Control.Monad.Ref (MonadRef(..))
27+import Control.Monad.Ref (MonadRef(..), MonadAtomicRef(..))
2828import Data.IORef (IORef, newIORef)
2929import Data.Semigroup (Semigroup)
3030import Data.Text (Text)
@@ -165,6 +165,8 @@ instance Monad m => MonadRef (UnrunnableT js t m) where
165165 newRef _ = unrunnable
166166 readRef _ = unrunnable
167167 writeRef _ _ = unrunnable
168+instance Monad m => MonadAtomicRef (UnrunnableT js t m) where
169+ atomicModifyRef _ _ = unrunnable
168170instance Monad m => HasDocument (UnrunnableT js t m) where
169171 askDocument = unrunnable
170172instance Monad m => HasJSContext (UnrunnableT js t m) where
@@ -203,12 +205,13 @@ instance Monad m => MonadReflexCreateTrigger t (UnrunnableT js t m) where
203205 newFanEventWithTrigger _ = unrunnable
204206instance Monad m => MonadFix (UnrunnableT js t m) where
205207 mfix _ = unrunnable
206−instance Monad m => MonadHold t (UnrunnableT js t m) where
208+instance (Monad m, MonadHold t m) => MonadHold t (UnrunnableT js t m) where
207209 hold _ _ = unrunnable
208210 holdDyn _ _ = unrunnable
209211 holdIncremental _ _ = unrunnable
210212 buildDynamic _ _ = unrunnable
211213 headE _ = unrunnable
214+ now = unrunnable
212215instance Monad m => MonadSample t (UnrunnableT js t m) where
213216 sample _ = unrunnable
214217instance Monad m => MonadIO (UnrunnableT js t m) where
@@ -226,7 +229,7 @@ instance (Reflex t, Monad m) => DomRenderHook t (UnrunnableT js t m) where
226229 withRenderHook _ _ = unrunnable
227230 requestDomAction _ = unrunnable
228231 requestDomAction_ _ = unrunnable
229−instance (Reflex t, Monad m) => Prerender JS' t (UnrunnableT js t m) where
232+instance (Reflex t, Monad m, MonadHold t m) => Prerender JS' t (UnrunnableT js t m) where
230233 type Client (UnrunnableT js t m) = UnrunnableT js t m
231234 prerender _ _ = unrunnable
232235
reflex-dom-core/src/Reflex/Dom/Widget/Input.hs+4−4
@@ -437,9 +437,12 @@ dropdown k0 options (DropdownConfig setK attrs) = do
437437 let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os
438438 in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)
439439 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
440+ postBuild <- getPostBuild
441+ let setSelection = attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys $
442+ leftmost [setK, k0 <$ postBuild]
440443 let cfg = def
441444 & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
442− & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)
445+ & selectElementConfig_setValue .~ fmap (T.pack . show) setSelection
443446 (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do
444447 let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey
445448 elDynAttr "option" optionAttrs $ dynText v
@@ -626,9 +629,6 @@ instance HasAttributes (FileInputConfig t) where
626629 type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)
627630 attributes = fileInputConfig_attributes
628631
629−class HasSetValue a where
630− type SetValue a :: *
631− setValue :: Lens' a (SetValue a)
632632
633633instance HasSetValue (TextAreaConfig t) where
634634 type SetValue (TextAreaConfig t) = Event t Text
reflex-dom-core/src/Reflex/Dom/Widget/Lazy.hs+1−1
@@ -117,7 +117,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
117117 "overflow" =: "hidden" <>
118118 "position" =: "relative"
119119 mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>
120− "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>
120+ "top" =: (<> "px") (T.pack $ show $ keyToIndex k * rowPx) <>
121121 "position" =: "absolute" <>
122122 "width" =: "100%"
123123 findWindow sizeIncrement windowSize startingPosition =
reflex-dom-core/src/Reflex/Dom/Widget/Resize.hs+4−4
@@ -37,19 +37,19 @@ import qualified GHCJS.DOM.Types as DOM
3737-- This function can cause strange scrollbars to appear in some circumstances.
3838-- These can be hidden with pseudo selectors, for example, in webkit browsers:
3939-- .wrapper *::-webkit-scrollbar { width: 0px; background: transparent; }
40−resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)
40+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (Maybe Double, Maybe Double), a)
4141resizeDetector = resizeDetectorWithStyle ""
4242
4343resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
4444 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
4545 -> m a -- ^ The embedded widget
46− -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
46+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
4747resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
4848
4949resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
5050 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
5151 -> m a -- ^ The embedded widget
52− -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
52+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
5353resizeDetectorWithAttrs attrs w = do
5454 let childStyle = "position: absolute; left: 0; top: 0;"
5555 containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
@@ -91,4 +91,4 @@ resizeDetectorWithAttrs attrs w = do
9191 size0 <- performEvent $ fmap (const $ liftJSM reset) pb
9292 rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
9393 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
94− return (fmapMaybe void resize, w')
94+ return (updated dimensions, w')
reflex-dom-core/test/gc.hs+1−1
@@ -47,7 +47,7 @@ failureLimit = 0
4747
4848main :: IO ()
4949main = do
50− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
50+ handle (\(_ :: IOError) -> return ()) $ unshareNetwork -- If we run into an exception with sandboxing, just don't bother
5151 withSandboxedChromeFlags True $ \chromeFlags -> do
5252 mainThread <- myThreadId
5353 browserProcess <- spawnCommand $ mconcat
reflex-dom-core/test/hlint.hs+1−1
@@ -1,4 +1,4 @@
1−import Language.Haskell.HLint3 (hlint)
1+import Language.Haskell.HLint (hlint)
22import System.Exit (exitFailure, exitSuccess)
33
44main :: IO ()
reflex-dom-core/test/hydration.hs+385−41
@@ -20,6 +20,14 @@
2020
2121{-# OPTIONS_GHC -fno-warn-orphans #-}
2222
23+-- Notice to those working on this test suite:
24+-- It doesn't appear to be possible to use --match to run a particular test, in
25+-- this situation the test may hang before reaching our code. This seems to
26+-- happen when the test is not the first test in the block. As a workaround, you
27+-- can just comment out the other tests. Also, using `xit` will cause the same
28+-- issue. `xit` tests must be the last tests in the session, or the session will
29+-- hang in the following test.
30+
2331import Prelude hiding (fail)
2432import Control.Concurrent
2533import qualified Control.Concurrent.Async as Async
@@ -39,6 +47,7 @@ import Data.Functor.Misc
3947import Data.GADT.Compare.TH
4048import Data.GADT.Show.TH
4149import Data.IORef (IORef)
50+import Data.List (sort)
4251import Data.Maybe
4352import Data.Proxy
4453import Data.Text (Text)
@@ -49,6 +58,7 @@ import Network.Socket
4958import Network.Wai
5059import Network.WebSockets
5160import Reflex.Dom.Core
61+import Reflex.Dom.Widget.Input (dropdown)
5262import Reflex.Patch.DMapWithMove
5363import System.Directory
5464import System.Environment
@@ -57,7 +67,7 @@ import System.IO.Silently
5767import System.IO.Temp
5868import System.Process
5969import System.Which (staticWhich)
60−import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
70+import qualified Test.HUnit as HUnit
6171import qualified Test.Hspec as H
6272import qualified Test.Hspec.Core.Spec as H
6373import Test.Hspec (xit)
@@ -97,11 +107,14 @@ instance MonadRef WD where
97107 writeRef r = WD . writeRef r
98108
99109assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
100−assertEqual a b = liftIO . HUnit.assertEqual a b
110+assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
101111
102112assertFailure :: MonadIO m => String -> m ()
103113assertFailure = liftIO . HUnit.assertFailure
104114
115+assertBool :: (MonadIO m) => String -> Bool -> m ()
116+assertBool msg bool = liftIO $ HUnit.assertBool msg bool
117+
105118chromeConfig :: Text -> [Text] -> WD.WDConfig
106119chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
107120
@@ -132,7 +145,7 @@ deriving instance MonadFail WD
132145
133146main :: IO ()
134147main = do
135− unshareNetork
148+ unshareNetwork
136149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
137150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
138151 withSeleniumServer $ \selenium -> do
@@ -141,13 +154,13 @@ main = do
141154 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
142155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
143156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
144− hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
157+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
145158
146−tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
159+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
147160tests withDebugging wdConfig caps _selenium = do
148161 let putStrLnDebug :: MonadIO m => Text -> m ()
149162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
150− session' = sessionWith wdConfig "" . using (map (,"") caps)
163+ session' t = sessionWith wdConfig t . using caps
151164 runWD m = runWDOptions (WdOptions False) $ do
152165 putStrLnDebug "before"
153166 r <- m
@@ -156,10 +169,10 @@ tests withDebugging wdConfig caps _selenium = do
156169 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
157170 testWidgetStatic = testWidgetStaticDebug withDebugging
158171 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
159− testWidget = testWidgetDebug withDebugging
172+ testWidget = testWidgetDebug True withDebugging
160173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
161− testWidget' = testWidgetDebug' withDebugging
162− describe "text" $ session' $ do
174+ testWidget' = testWidgetDebug' True withDebugging
175+ session' "text" $ do
163176 it "works" $ runWD $ do
164177 testWidgetStatic (checkBodyText "hello world") $ do
165178 text "hello world"
@@ -220,7 +233,7 @@ tests withDebugging wdConfig caps _selenium = do
220233 click <- button ""
221234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
222235
223− describe "element" $ session' $ do
236+ session' "element" $ do
224237 it "works with domEvent Click" $ runWD $ do
225238 clickedRef <- liftIO $ newRef False
226239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -284,21 +297,78 @@ tests withDebugging wdConfig caps _selenium = do
284297 let click = domEvent Click e
285298 return ()
286299
287− describe "inputElement" $ do
288− describe "hydration" $ session' $ do
300+ session' "inputElement" $ do
301+ describe "static renderer" $ do
302+ it "sets value attribute" $ runWD $ do
303+ let checkStatic = do
304+ e <- findElemWithRetry $ WD.ByTag "input"
305+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
306+ pure e
307+ checkHydrated e = do
308+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
309+ testWidget' checkStatic checkHydrated $ void $ inputElement $ def
310+ & inputElementConfig_initialValue .~ "test"
311+ it "updates value attribute at postBuild" $ runWD $ do
312+ let checkStatic = do
313+ e <- findElemWithRetry $ WD.ByTag "input"
314+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
315+ pure e
316+ checkHydrated e = do
317+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
318+ testWidget' checkStatic checkHydrated $ do
319+ pb <- getPostBuild
320+ _ <- inputElement $ def
321+ & inputElementConfig_initialValue .~ "test"
322+ & inputElementConfig_setValue .~ ("test-updated" <$ pb)
323+ pure ()
324+ it "sets checked attr appropriately" $ runWD $ do
325+ setCheckedChan <- liftIO newChan
326+ let checkStatic = do
327+ e <- findElemWithRetry $ WD.ByTag "input"
328+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
329+ pure e
330+ checkValue e = do
331+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
332+ WD.moveToCenter e
333+ WD.click e -- Click to uncheck
334+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
335+ liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
336+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
337+ testWidget' checkStatic checkValue $ do
338+ setChecked <- triggerEventWithChan setCheckedChan
339+ _ <- inputElement $ def
340+ & initialAttributes .~ "type" =: "checkbox"
341+ & inputElementConfig_initialChecked .~ True
342+ & inputElementConfig_setChecked .~ setChecked
343+ pure ()
344+ it "sets checked attr appropriately at postbuild" $ runWD $ do
345+ let checkStatic = do
346+ e <- findElemWithRetry $ WD.ByTag "input"
347+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
348+ pure e
349+ checkValue e = do
350+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351+ testWidget' checkStatic checkValue $ do
352+ pb <- getPostBuild
353+ _ <- inputElement $ def
354+ & initialAttributes .~ "type" =: "checkbox"
355+ & inputElementConfig_initialChecked .~ False
356+ & inputElementConfig_setChecked .~ (True <$ pb)
357+ pure ()
358+ describe "hydration" $ do
289359 it "doesn't wipe user input when switching over" $ runWD $ do
290− inputRef <- newRef ("" :: Text)
360+ inputRef <- newRef ("hello " :: Text)
291361 testWidget'
292362 (do
293363 e <- findElemWithRetry $ WD.ByTag "input"
294− WD.sendKeys "hello world" e
364+ WD.sendKeys "world" e
295365 pure e)
296366 (\e -> do
297367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
298368 WD.click =<< findElemWithRetry (WD.ByTag "button")
299369 readRef inputRef `shouldBeWithRetryM` "hello world"
300370 ) $ do
301− e <- inputElement def
371+ e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
302372 click <- button "save"
303373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
304374 it "captures user input after switchover" $ runWD $ do
@@ -355,24 +425,49 @@ tests withDebugging wdConfig caps _selenium = do
355425 checkedByUIRef <- newRef False
356426 checkedRef <- newRef False
357427 setCheckedChan <- liftIO newChan
358− let checkValue = do
428+ let checkStatic = do
429+ e <- findElemWithRetry $ WD.ByTag "input"
430+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
431+ pure e
432+ checkValue e = do
359433 readRef checkedByUIRef `shouldBeWithRetryM` False
360434 readRef checkedRef `shouldBeWithRetryM` False
361− e <- findElemWithRetry $ WD.ByTag "input"
435+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
362436 WD.moveToCenter e
363437 WD.click e
364438 readRef checkedByUIRef `shouldBeWithRetryM` True
365439 readRef checkedRef `shouldBeWithRetryM` True
440+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
366441 liftIO $ writeChan setCheckedChan False
367442 readRef checkedByUIRef `shouldBeWithRetryM` True
368443 readRef checkedRef `shouldBeWithRetryM` False
369− testWidget (pure ()) checkValue $ do
444+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
445+ testWidget' checkStatic checkValue $ do
370446 setChecked <- triggerEventWithChan setCheckedChan
371447 e <- inputElement $ def
372448 & initialAttributes .~ "type" =: "checkbox"
373449 & inputElementConfig_setChecked .~ setChecked
374450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
375451 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
452+ it "respects user updates to checked which happen before hydration" $ runWD $ do
453+ checkedByUIRef <- newRef False
454+ checkedRef <- newRef False
455+ let checkStatic = do
456+ e <- findElemWithRetry $ WD.ByTag "input"
457+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
458+ WD.moveToCenter e
459+ WD.click e
460+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
461+ pure e
462+ checkValue e = do
463+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
464+ readRef checkedByUIRef `shouldBeWithRetryM` True
465+ readRef checkedRef `shouldBeWithRetryM` True
466+ testWidget' checkStatic checkValue $ do
467+ e <- inputElement $ def
468+ & initialAttributes .~ "type" =: "checkbox"
469+ performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
470+ performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
376471 it "captures file uploads" $ runWD $ do
377472 filesRef :: IORef [Text] <- newRef []
378473 let uploadFile = do
@@ -388,8 +483,117 @@ tests withDebugging wdConfig caps _selenium = do
388483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
389484 names <- liftJSM $ traverse File.getName fs
390485 liftIO $ writeRef filesRef names
391−
392− describe "hydration/immediate" $ session' $ do
486+ it "fires _input event if the user altered the value before hydration" $ runWD $ do
487+ input <- newRef ("" :: Text)
488+ update <- newRef ("" :: Text)
489+ let checkStatic = do
490+ e <- findElemWithRetry $ WD.ByTag "input"
491+ WD.attr e "value" `shouldBeWithRetryM` Just ""
492+ WD.sendKeys "test" e
493+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
494+ pure e
495+ checkHydrated e = do
496+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
497+ readRef input `shouldBeWithRetryM` "test"
498+ readRef update `shouldBeWithRetryM` "test"
499+ testWidget' checkStatic checkHydrated $ do
500+ e <- inputElement def
501+ performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
502+ performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
503+ it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
504+ input <- newRef (Nothing :: Maybe Text)
505+ let checkStatic = do
506+ e <- findElemWithRetry $ WD.ByTag "input"
507+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
508+ pure e
509+ checkHydrated e = do
510+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
511+ readRef input `shouldBeWithRetryM` Nothing
512+ testWidget' checkStatic checkHydrated $ do
513+ pb <- getPostBuild
514+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
515+ performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
516+ it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
517+ let checkBoth = do
518+ input <- findElemWithRetry $ WD.ByTag "input"
519+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
520+ p <- findElemWithRetry (WD.ByTag "p")
521+ shouldContainText "pb" p
522+ testWidget checkBoth checkBoth $ do
523+ pb <- getPostBuild
524+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
525+ el "p" $ dynText $ _inputElement_value e
526+ it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
527+ let checkStatic = do
528+ input <- findElemWithRetry $ WD.ByTag "input"
529+ h2_value <- findElemWithRetry (WD.ByTag "h2")
530+ h3_input <- findElemWithRetry (WD.ByTag "h3")
531+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
532+ shouldContainText "pb" h2_value
533+ shouldContainText "" h3_input
534+ WD.sendKeys "abc" input
535+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
536+ shouldContainText "pb" h2_value
537+ shouldContainText "" h3_input
538+ pure (input, h2_value, h3_input)
539+ checkHydrated (input, h2_value, h3_input) = do
540+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
541+ shouldContainText "pbabc" h3_input
542+ shouldContainText "pbabc pb" h2_value
543+ pure ()
544+ testWidget' checkStatic checkHydrated $ do
545+ pb <- getPostBuild
546+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
547+ el "h1" $ dynText $ _inputElement_value e
548+ el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
549+ el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
550+ it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
551+ let checkStatic = do
552+ input <- findElemWithRetry $ WD.ByTag "input"
553+ p <- findElemWithRetry (WD.ByTag "p")
554+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
555+ shouldContainText "pb" p
556+ WD.sendKeys "abc" input
557+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
558+ shouldContainText "pb" p -- It won't be updated yet
559+ pure (input, p)
560+ checkHydrated (input, p) = do
561+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
562+ shouldContainText "pbabc" p
563+ pure ()
564+ testWidget' checkStatic checkHydrated $ do
565+ pb <- getPostBuild
566+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
567+ el "p" $ dynText $ _inputElement_value e
568+ it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
569+ valRef <- newRef ([] :: [Text])
570+ inputRef <- newRef ([] :: [Text])
571+ let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
572+ checkStatic = do
573+ input <- findElemWithRetry $ WD.ByTag "input"
574+ p <- findElemWithRetry (WD.ByTag "p")
575+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"
576+ shouldContainText "pb" p
577+ WD.sendKeys "abc" input
578+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
579+ shouldContainText "pb" p -- It won't be updated yet
580+ readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
581+ readRef valRef `shouldBeWithRetryM` ["pb"]
582+ pure (input, p)
583+ checkHydrated (input, p) = do
584+ readRef inputRef `shouldBeWithRetryM` ["pbabc"]
585+ readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
586+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
587+ shouldContainText "pbabc" p
588+ pure ()
589+ testWidget' checkStatic checkHydrated $ do
590+ liftIO $ writeRef valRef []
591+ pb <- getPostBuild
592+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
593+ el "p" $ dynText $ _inputElement_value e
594+ performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
595+ performEvent_ $ consRef inputRef <$> _inputElement_input e
596+ describe "hydration/immediate" $ do
393597 it "captures user input after switchover" $ runWD $ do
394598 inputRef :: IORef Text <- newRef ""
395599 let checkValue = do
@@ -469,8 +673,31 @@ tests withDebugging wdConfig caps _selenium = do
469673 names <- liftJSM $ traverse File.getName fs
470674 liftIO $ writeRef filesRef names
471675
472− describe "textAreaElement" $ do
473− describe "hydration" $ session' $ do
676+ session' "textAreaElement" $ do
677+ describe "static renderer" $ do
678+ it "sets value attribute" $ runWD $ do
679+ let checkStatic = do
680+ e <- findElemWithRetry $ WD.ByTag "textarea"
681+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
682+ pure e
683+ checkHydrated e = do
684+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
685+ testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
686+ & textAreaElementConfig_initialValue .~ "test"
687+ it "updates value attribute at postBuild" $ runWD $ do
688+ let checkStatic = do
689+ e <- findElemWithRetry $ WD.ByTag "textarea"
690+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
691+ pure e
692+ checkHydrated e = do
693+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
694+ testWidget' checkStatic checkHydrated $ do
695+ pb <- getPostBuild
696+ _ <- textAreaElement $ def
697+ & textAreaElementConfig_initialValue .~ "test"
698+ & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
699+ pure ()
700+ describe "hydration" $ do
474701 it "doesn't wipe user input when switching over" $ runWD $ do
475702 inputRef <- newRef ("" :: Text)
476703 testWidget'
@@ -536,8 +763,90 @@ tests withDebugging wdConfig caps _selenium = do
536763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
537764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
538765 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
766+ it "fires _input event if the user altered the value before hydration" $ runWD $ do
767+ textarea <- newRef ("" :: Text)
768+ update <- newRef ("" :: Text)
769+ let checkStatic = do
770+ e <- findElemWithRetry $ WD.ByTag "textarea"
771+ WD.attr e "value" `shouldBeWithRetryM` Just ""
772+ WD.sendKeys "test" e
773+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
774+ pure e
775+ checkHydrated e = do
776+ WD.attr e "value" `shouldBeWithRetryM` Just "test"
777+ readRef textarea `shouldBeWithRetryM` "test"
778+ readRef update `shouldBeWithRetryM` "test"
779+ testWidget' checkStatic checkHydrated $ do
780+ e <- textAreaElement def
781+ performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
782+ performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
783+ it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
784+ textarea <- newRef (Nothing :: Maybe Text)
785+ let checkStatic = do
786+ e <- findElemWithRetry $ WD.ByTag "textarea"
787+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
788+ pure e
789+ checkHydrated e = do
790+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"
791+ readRef textarea `shouldBeWithRetryM` Nothing
792+ testWidget' checkStatic checkHydrated $ do
793+ pb <- getPostBuild
794+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
795+ performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
796+ it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
797+ let checkBoth = do
798+ textarea <- findElemWithRetry $ WD.ByTag "textarea"
799+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
800+ p <- findElemWithRetry (WD.ByTag "p")
801+ shouldContainText "pb" p
802+ testWidget checkBoth checkBoth $ do
803+ pb <- getPostBuild
804+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
805+ el "p" $ dynText $ _textAreaElement_value e
806+ it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
807+ let checkStatic = do
808+ textarea <- findElemWithRetry $ WD.ByTag "textarea"
809+ h2_value <- findElemWithRetry (WD.ByTag "h2")
810+ h3_input <- findElemWithRetry (WD.ByTag "h3")
811+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
812+ shouldContainText "pb" h2_value
813+ shouldContainText "" h3_input
814+ WD.sendKeys "abc" textarea
815+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
816+ shouldContainText "pb" h2_value
817+ shouldContainText "" h3_input
818+ pure (textarea, h2_value, h3_input)
819+ checkHydrated (textarea, h2_value, h3_input) = do
820+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
821+ shouldContainText "pbabc" h3_input
822+ shouldContainText "pbabc pb" h2_value
823+ pure ()
824+ testWidget' checkStatic checkHydrated $ do
825+ pb <- getPostBuild
826+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
827+ el "h1" $ dynText $ _textAreaElement_value e
828+ el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
829+ el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
830+ it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
831+ let checkStatic = do
832+ textarea <- findElemWithRetry $ WD.ByTag "textarea"
833+ p <- findElemWithRetry (WD.ByTag "p")
834+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
835+ shouldContainText "pb" p
836+ WD.sendKeys "abc" textarea
837+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
838+ shouldContainText "pb" p -- It won't be updated yet
839+ pure (textarea, p)
840+ checkHydrated (textarea, p) = do
841+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
842+ shouldContainText "pbabc" p
843+ pure ()
844+ testWidget' checkStatic checkHydrated $ do
845+ pb <- getPostBuild
846+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
847+ el "p" $ dynText $ _textAreaElement_value e
539848
540− describe "hydration/immediate" $ session' $ do
849+ describe "hydration/immediate" $ do
541850 it "captures user input after switchover" $ runWD $ do
542851 inputRef :: IORef Text <- newRef ""
543852 let checkValue = do
@@ -579,13 +888,13 @@ tests withDebugging wdConfig caps _selenium = do
579888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
580889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
581890
582− describe "selectElement" $ do
891+ session' "selectElement" $ do
583892 let options :: DomBuilder t m => m ()
584893 options = do
585894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
586895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
587896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
588− describe "hydration" $ session' $ do
897+ describe "hydration" $ do
589898 it "sets initial value correctly" $ runWD $ do
590899 inputRef <- newRef ("" :: Text)
591900 let setup = do
@@ -659,7 +968,7 @@ tests withDebugging wdConfig caps _selenium = do
659968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
660969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
661970
662− describe "hydration/immediate" $ session' $ do
971+ describe "hydration/immediate" $ do
663972 it "captures user input after switchover" $ runWD $ do
664973 inputRef :: IORef Text <- newRef ""
665974 let checkValue = do
@@ -705,7 +1014,7 @@ tests withDebugging wdConfig caps _selenium = do
7051014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
7061015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
7071016
708− describe "prerender" $ session' $ do
1017+ session' "prerender" $ do
7091018 it "works in simple case" $ runWD $ do
7101019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
7111020 prerender_ (text "One") (text "Two")
@@ -774,7 +1083,7 @@ tests withDebugging wdConfig caps _selenium = do
7741083 prerender_ (pure ()) (liftIO $ trigger "Client")
7751084 textNode $ TextNodeConfig "Initial" $ Just e
7761085
777− describe "namespaces" $ session' $ do
1086+ session' "namespaces" $ do
7781087 it "dyn can be nested in namespaced widget" $ runWD $ do
7791088 testWidget (pure ()) (checkTextInTag "svg" "one") $ do
7801089 let svgRootCfg = def
@@ -783,7 +1092,7 @@ tests withDebugging wdConfig caps _selenium = do
7831092 void $ element "svg" svgRootCfg $ do
7841093 dyn_ $ text "one" <$ pure ()
7851094
786− describe "runWithReplace" $ session' $ do
1095+ session' "runWithReplace" $ do
7871096 it "works" $ runWD $ do
7881097 replaceChan :: Chan Text <- liftIO newChan
7891098 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -957,7 +1266,9 @@ tests withDebugging wdConfig caps _selenium = do
9571266 _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
9581267 text "|after"
9591268 void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
960− it "ignores missing ending bracketing comments" $ runWD $ do
1269+ -- TODO This test actually causes a hydration failure, but it wasn't
1270+ -- previously detected, so I've marked it pending
1271+ xit "ignores missing ending bracketing comments" $ runWD $ do
9611272 replaceChan :: Chan () <- liftIO newChan
9621273 let
9631274 preSwitchover = do
@@ -979,7 +1290,7 @@ tests withDebugging wdConfig caps _selenium = do
9791290 _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
9801291 text "|after"
9811292
982− describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1293+ session' "traverseDMapWithKeyWithAdjust" $ do
9831294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
9841295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
9851296 elClass "span" "key" $ text $ textKey k
@@ -1082,7 +1393,7 @@ tests withDebugging wdConfig caps _selenium = do
10821393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
10831394 liftIO $ dmap `H.shouldBe` keyMap
10841395
1085− describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1396+ session' "traverseIntMapWithKeyWithAdjust" $ do
10861397 let textKeyInt k = "key" <> T.pack (show k)
10871398 intMap = IntMap.fromList
10881399 [ (1, "one")
@@ -1189,7 +1500,7 @@ tests withDebugging wdConfig caps _selenium = do
11891500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
11901501 liftIO $ dmap `H.shouldBe` intMap
11911502
1192− describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1503+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do
11931504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
11941505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
11951506 elClass "span" "key" $ text $ textKey2 k
@@ -1269,8 +1580,8 @@ tests withDebugging wdConfig caps _selenium = do
12691580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
12701581 liftIO $ assertEqual "DMap" initMap dmap
12711582
1272− describe "hydrating invalid HTML" $ session' $ do
1273− it "can hydrate list in paragraph" $ runWD $ do
1583+ session' "hydrating invalid HTML" $ do
1584+ xit "can hydrate list in paragraph" $ runWD $ do
12741585 let preSwitchover = do
12751586 checkBodyText "before\ninner\nafter"
12761587 -- Two <p> tags should be present
@@ -1287,7 +1598,8 @@ tests withDebugging wdConfig caps _selenium = do
12871598 shouldContainText "before\ninner\nafter" p1
12881599 elementShouldBeRemoved ol
12891600 elementShouldBeRemoved p2
1290− testWidget' preSwitchover check $ do
1601+ -- Don't fail fatally when hydration encounters the invalid DOM
1602+ testWidgetDebug' False withDebugging preSwitchover check $ do
12911603 -- This is deliberately invalid HTML, the browser will interpret it as
12921604 -- <p>before</p><ol>inner</ol>after<p></p>
12931605 el "p" $ do
@@ -1295,6 +1607,29 @@ tests withDebugging wdConfig caps _selenium = do
12951607 el "ol" $ text "inner"
12961608 text "after"
12971609
1610+ -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
1611+ -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
1612+ -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1613+ session' "dropdown" $ do
1614+ let doTest expectedOpts (initialValue :: Text) = do
1615+ let doCheck = do
1616+ es <- findElemsWithRetry $ WD.ByTag "option"
1617+ opts <- mapM fetchElement es
1618+ assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
1619+ testWidget doCheck doCheck $ do
1620+ void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
1621+ fetchElement e = do
1622+ val <- WD.attr e "value"
1623+ sel <- WD.attr e "selected"
1624+ return (fromMaybe "" val, isJust sel)
1625+ -- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)
1626+ -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
1627+ xit "statically renders initial values (on aa)" $ runWD $ do
1628+ doTest [("0",True),("1",False)] "aa"
1629+ -- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well
1630+ xit "statically renders initial values (on bb)" $ runWD $ do
1631+ doTest [("0",False),("1",True)] "bb"
1632+
12981633data Selenium = Selenium
12991634 { _selenium_portNumber :: PortNumber
13001635 , _selenium_stopServer :: IO ()
@@ -1362,6 +1697,9 @@ checkTextInId i expected = do
13621697findElemWithRetry :: Selector -> WD WD.Element
13631698findElemWithRetry = withRetry . WD.findElem
13641699
1700+findElemsWithRetry :: Selector -> WD [WD.Element]
1701+findElemsWithRetry = withRetry . WD.findElems
1702+
13651703getBody :: WD WD.Element
13661704getBody = WD.findElem $ WD.ByTag "body"
13671705
@@ -1387,11 +1725,12 @@ testWidgetStaticDebug
13871725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
13881726 -- ^ Widget we are testing
13891727 -> WD b
1390−testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1728+testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
13911729
13921730-- | TODO: do something about JSExceptions not causing tests to fail
13931731testWidgetDebug
13941732 :: Bool
1733+ -> Bool
13951734 -> WD ()
13961735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
13971736 -> WD b
@@ -1399,12 +1738,16 @@ testWidgetDebug
13991738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
14001739 -- ^ Widget we are testing
14011740 -> WD b
1402−testWidgetDebug withDebugging beforeJS afterSwitchover =
1403− testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1741+testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1742+ testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1743+
1744+data HydrationFailedException = HydrationFailedException deriving Show
1745+instance Exception HydrationFailedException
14041746
14051747-- | TODO: do something about JSExceptions not causing tests to fail
14061748testWidgetDebug'
14071749 :: Bool
1750+ -> Bool
14081751 -> WD a
14091752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
14101753 -> (a -> WD b)
@@ -1412,7 +1755,7 @@ testWidgetDebug'
14121755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
14131756 -- ^ Widget we are testing (contents of body)
14141757 -> WD b
1415−testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1758+testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
14161759 let putStrLnDebug :: MonadIO m => Text -> m ()
14171760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
14181761 staticApp = do
@@ -1424,6 +1767,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
14241767 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
14251768 putStrLnDebug "rendered static"
14261769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770+ onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
14271771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
14281772 let entryPoint = do
14291773 putStrLnDebug "taking waitBeforeJS"
@@ -1435,7 +1779,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
14351779 liftIO $ putMVar waitUntilSwitchover ()
14361780 putStrLnDebug "put waitUntilSwitchover"
14371781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1438− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1782+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
14391783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
14401784 syncPoint
14411785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
reflex-dom-test-selenium/CHANGELOG.mdnew file+5
@@ -0,0 +1,5 @@
1+# Revision history for reflex-dom-core-selenium
2+
3+## 0.1.0.0 -- YYYY-mm-dd
4+
5+* First version. Released on an unsuspecting world.
reflex-dom-test-selenium/LICENSEnew file+12
@@ -0,0 +1,12 @@
1+Copyright (c) 2020, Obsidian Systems LLC
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5+
6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7+
8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9+
10+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+
12+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
reflex-dom-test-selenium/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
reflex-dom-test-selenium/add-overrides.nixnew file+20
@@ -0,0 +1,20 @@
1+{ nixpkgs }: testPackage:
2+ nixpkgs.haskell.lib.overrideCabal testPackage
3+ (drv: {
4+
5+ # The headless browser run as part of the tests will exit without this
6+ preBuild = ''
7+ export HOME="$PWD"
8+ '';
9+
10+ testSystemDepends = with nixpkgs; (drv.testSystemDepends or []) ++ [
11+ selenium-server-standalone which
12+ chromium
13+ nixpkgs.iproute
14+ ];
15+
16+ # The headless browser run as part of gc tests would hang/crash without this
17+ preCheck = ''
18+ export FONTCONFIG_PATH=${nixpkgs.fontconfig.out}/etc/fonts
19+ '';
20+ })
reflex-dom-test-selenium/reflex-dom-test-selenium.cabalnew file+41
@@ -0,0 +1,41 @@
1+cabal-version: 1.24
2+Name: reflex-dom-test-selenium
3+Version: 0.0.0.1
4+Synopsis: Testing framework for selenium tests
5+Description:
6+License: BSD3
7+License-file: LICENSE
8+Author: Ryan Trinkle
9+Maintainer: ryan.trinkle@gmail.com
10+Stability: Experimental
11+Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
12+Build-type: Simple
13+
14+library
15+ hs-source-dirs: src
16+ build-depends:
17+ async,
18+ base >= 4.7 && < 4.15,
19+ bytestring == 0.10.*,
20+ chrome-test-utils,
21+ exceptions,
22+ hspec-core,
23+ hspec-webdriver >= 1.2.1,
24+ http-types,
25+ jsaddle >= 0.9.0.0 && < 0.10,
26+ jsaddle-warp,
27+ network,
28+ process,
29+ reflex-dom-core,
30+ silently,
31+ text == 1.2.*,
32+ wai,
33+ warp,
34+ webdriver,
35+ websockets
36+
37+ exposed-modules:
38+ Reflex.Dom.Test.Selenium
39+
40+ default-language: Haskell98
41+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively
reflex-dom-test-selenium/src/Reflex/Dom/Test/Selenium.hsnew file+249
@@ -0,0 +1,249 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+
10+{-# OPTIONS_GHC -fno-warn-orphans #-}
11+
12+-- | Utilities for testing reflex-dom widgets with Selenium.
13+--
14+-- Any uses of the 'testWidget' functions will start a jsaddle warp server and
15+-- serve the given widget in an otherwise empty page. Webdriver commands can run
16+-- on the statically rendered page, and on the hydrated page.
17+module Reflex.Dom.Test.Selenium
18+ ( TestWidget
19+ , TestWidgetConfig (..)
20+ , testWidget, testWidget', testWidgetStatic, testWidgetHydrated
21+ , withSeleniumSpec
22+ , embedSpec
23+ , SeleniumSetupConfig (..)
24+ ) where
25+
26+import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)
27+import Control.Exception (throwIO)
28+import Control.Monad (when)
29+import Control.Monad.Catch (MonadMask, handle)
30+import Control.Monad.Fix (MonadFix)
31+import Control.Monad.IO.Class (MonadIO, liftIO)
32+import Data.Text (Text)
33+import Language.Javascript.JSaddle
34+import Language.Javascript.JSaddle.Warp
35+import Network.HTTP.Types (status200)
36+import Network.Socket (PortNumber)
37+import Network.Wai (responseLBS)
38+import Network.WebSockets (defaultConnectionOptions)
39+import Reflex.Dom.Core
40+import System.IO (stderr)
41+import System.IO.Silently (hSilence)
42+import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)
43+import Test.Hspec.WebDriver (Spec, SpecWith, WdTestSession, sessionWith, using)
44+import Test.Util.ChromeFlags
45+import Test.Util.UnshareNetwork
46+import Test.WebDriver (WD)
47+
48+import qualified Control.Concurrent.Async as Async
49+import qualified Data.ByteString.Lazy as LBS
50+import qualified Data.Text as T
51+import qualified Data.Text.Encoding as TE
52+import qualified Network.Wai.Handler.Warp as Warp
53+import qualified Test.Hspec.Core.Spec as Hspec
54+import qualified Test.WebDriver as WD
55+import qualified Test.WebDriver.Capabilities as WD
56+
57+deriving instance MonadMask WD
58+
59+data SeleniumSetupConfig = SeleniumSetupConfig
60+ { _seleniumSetupConfig_chromiumPath :: FilePath
61+ -- ^ Path to the chromium executable
62+ , _seleniumSetupConfig_headless :: Bool
63+ -- ^ True means that the browser is invoked in headless mode, False means that
64+ -- the user can see the interaction happening on the browser (useful for debugging).
65+ , _seleniumSetupConfig_seleniumPort :: PortNumber
66+ -- ^ The port number used by selenium
67+ }
68+
69+-- | Setup a selenium server and use it to run some hspec tests.
70+--
71+-- withSeleniumSpec config $ \runSession -> hspec $ do
72+-- describe "tests using webdriver session" $ runSession $ do
73+-- webdriver tests here
74+withSeleniumSpec :: SeleniumSetupConfig -> ((forall multi. SpecWith (WdTestSession multi) -> Spec) -> IO a) -> IO a
75+withSeleniumSpec config runSpec = do
76+ liftIO $ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
77+ withSandboxedChromeFlags (_seleniumSetupConfig_headless config) $ \chromeFlags -> do
78+ withSeleniumServer (_seleniumSetupConfig_seleniumPort config) $ do
79+ let browserPath = T.strip $ T.pack $ _seleniumSetupConfig_chromiumPath config
80+ when (T.null browserPath) $ fail "No browser found"
81+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _seleniumSetupConfig_seleniumPort config }
82+ chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
83+ runSpec $ sessionWith wdConfig "" . using [(chromeCaps', "chrome")]
84+
85+startSeleniumServer :: PortNumber -> IO (IO ())
86+startSeleniumServer port = do
87+ (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
88+ { std_in = NoStream
89+ , std_out = NoStream
90+ , std_err = NoStream
91+ }
92+ return $ terminateProcess ph
93+
94+withSeleniumServer :: PortNumber -> IO a -> IO a
95+withSeleniumServer port f = bracket (startSeleniumServer port) id $ \_ -> do
96+ threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
97+ f
98+
99+chromeConfig :: Text -> [Text] -> WD.WDConfig
100+chromeConfig fp flags =
101+ WD.useBrowser
102+ (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags })
103+ WD.defaultConfig
104+
105+--------------------------------------------------------------------------------
106+-- Function to test widgets
107+--------------------------------------------------------------------------------
108+
109+-- | The environment in which your widgets can be tested
110+type TestWidget js t m =
111+ (DomBuilder t m, MonadHold t m, PostBuild t m
112+ , Prerender js t m, PerformEvent t m, TriggerEvent t m
113+ , MonadFix m, MonadIO (Performable m), MonadIO m)
114+
115+-- | Configuration of individual tests
116+data TestWidgetConfig = TestWidgetConfig
117+ { _testWidgetConfig_debug :: Bool
118+ -- ^ If this flag is set to True, during the test we will emit debug messages
119+ , _testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
120+ -- ^ We can add widgets here that will be included in the head of the page
121+ -- (useful for example to include external js libraries in the tests)
122+ , _testWidgetConfig_jsaddlePort :: PortNumber
123+ -- ^ Port used by the jsaddle server
124+ }
125+
126+-- | Test a widget by running some webdriver commands before and after
127+-- hydration.
128+testWidget
129+ :: TestWidgetConfig
130+ -> WD a
131+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
132+ -> WD b
133+ -- ^ Webdriver commands to run after hydration switchover
134+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
135+ -- ^ Widget we are testing (contents of body)
136+ -> WD b
137+testWidget cfg before after widget = testWidget' cfg before (const after) widget
138+
139+-- | Test a widget by running some webdriver commands before hydration (on the
140+-- statically rendered page).
141+testWidgetStatic
142+ :: TestWidgetConfig
143+ -> WD a
144+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
145+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
146+ -- ^ Widget we are testing (contents of body)
147+ -> WD a
148+testWidgetStatic cfg before widget = testWidget' cfg before pure widget
149+
150+-- | Test a widget by running some webdriver commands after hydration.
151+testWidgetHydrated
152+ :: TestWidgetConfig
153+ -> WD b
154+ -- ^ Webdriver commands to run after hydration switchover
155+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
156+ -- ^ Widget we are testing (contents of body)
157+ -> WD b
158+testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget
159+
160+-- | Test a widget by running some webdriver commands before and after
161+-- hydration. Like 'testWidget', but you can use the result of the webdriver
162+-- commands from before hydration in the post hydration test.
163+testWidget'
164+ :: TestWidgetConfig
165+ -> WD a
166+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
167+ -> (a -> WD b)
168+ -- ^ Webdriver commands to run after hydration switchover
169+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
170+ -- ^ Widget we are testing (contents of body)
171+ -> WD b
172+testWidget' (TestWidgetConfig withDebugging headWidget jsaddlePort) beforeJS afterSwitchover bodyWidget = do
173+ let putStrLnDebug :: MonadIO m => Text -> m ()
174+ putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
175+ staticApp = do
176+ el "head" $ headWidget
177+ el "body" $ do
178+ bodyWidget
179+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
180+ putStrLnDebug "rendering static"
181+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
182+ putStrLnDebug "rendered static"
183+ waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
184+ waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
185+ let entryPoint = do
186+ putStrLnDebug "taking waitBeforeJS"
187+ liftIO $ takeMVar waitBeforeJS
188+ let switchOverAction = do
189+ putStrLnDebug "switchover syncPoint"
190+ syncPoint
191+ putStrLnDebug "putting waitUntilSwitchover"
192+ liftIO $ putMVar waitUntilSwitchover ()
193+ putStrLnDebug "put waitUntilSwitchover"
194+ putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
195+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
196+ putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
197+ syncPoint
198+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
199+ putStrLnDebug "sending response"
200+ r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
201+ putStrLnDebug "sent response"
202+ return r
203+ waitJSaddle <- liftIO newEmptyMVar
204+ let settings = foldr ($) Warp.defaultSettings
205+ [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
206+ , Warp.setBeforeMainLoop $ do
207+ putStrLnDebug "putting waitJSaddle"
208+ putMVar waitJSaddle ()
209+ putStrLnDebug "put waitJSaddle"
210+ ]
211+ -- hSilence to get rid of ConnectionClosed logs
212+ silenceIfNotDebugging = if withDebugging then id else hSilence [stderr]
213+ jsaddleWarp = silenceIfNotDebugging $ Warp.runSettings settings application
214+ withAsync' jsaddleWarp $ do
215+ putStrLnDebug "taking waitJSaddle"
216+ liftIO $ takeMVar waitJSaddle
217+ putStrLnDebug "opening page"
218+ WD.openPage $ "http://localhost:" <> show jsaddlePort
219+ putStrLnDebug "running beforeJS"
220+ a <- beforeJS
221+ putStrLnDebug "putting waitBeforeJS"
222+ liftIO $ putMVar waitBeforeJS ()
223+ putStrLnDebug "taking waitUntilSwitchover"
224+ liftIO $ takeMVar waitUntilSwitchover
225+ putStrLnDebug "running afterSwitchover"
226+ afterSwitchover a
227+
228+--------------------------------------------------------------------------------
229+-- Utilities
230+--------------------------------------------------------------------------------
231+
232+-- | Embed a different spec type by evaluating it directly.
233+embedSpec :: (Hspec.Example a, MonadIO m) => Hspec.Arg a -> a -> m ()
234+embedSpec arg spec = liftIO $ do
235+ Hspec.Result _info status <- Hspec.evaluateExample
236+ spec
237+ Hspec.defaultParams
238+ (\actionWith -> actionWith arg)
239+ (\_ -> pure ())
240+ case status of
241+ Hspec.Success -> pure ()
242+ Hspec.Pending _ _ -> pure () -- should not happen
243+ failure -> throwIO failure
244+
245+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
246+withAsync' f g = bracket
247+ (liftIO $ Async.async f)
248+ (liftIO . Async.uninterruptibleCancel)
249+ (const g)
reflex-dom/ChangeLog.md+17−1
@@ -1,7 +1,23 @@
11# Revision history for reflex-dom
22
3−## Unreleased
3+## 0.6.1.0-r1
44
5+* Loosen reflex-dom-core version bounds
6+
7+## 0.6.1.0
8+
9+* Update for new dependent-map and dependent-sum (after the "some" package split)
10+
11+## 0.6.0.0
12+
13+* ([#379](https://github.com/reflex-frp/reflex-dom/pull/379)) Re-export all modules from `reflex-dom-core`. The newly re-exported modules are:
14+ * `Foreign.JavaScript.Utils`
15+ * `Reflex.Dom.Builder.Hydratable`
16+ * `Reflex.Dom.Modals.Class`
17+ * `Reflex.Dom.Prerender`
18+ * `Reflex.Dom.Time`
19+ * `Reflex.Dom.WebSocket.Query`
20+ * `Reflex.Dom.Xhr.FormData`
521* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
622
723## 0.5.3
reflex-dom/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015, Obsidian Systems LLC
1+Copyright (c) 2020, Obsidian Systems LLC
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
reflex-dom/benchmark.hs+2−1
@@ -15,8 +15,9 @@ import qualified Data.Text as T
1515import Reflex.Dom
1616import System.Random
1717import qualified Data.Map as Map
18−import Data.Dependent.Map (DMap (..), DSum (..))
18+import Data.Dependent.Map (DMap (..))
1919import qualified Data.Dependent.Map as DMap
20+import Data.Dependent.Sum (DSum (..))
2021import Data.Functor.Misc
2122import Data.Functor.Identity
2223import Data.Functor.Compose
reflex-dom/reflex-dom.cabal+68−22
@@ -1,10 +1,20 @@
1+cabal-version: 1.24
12Name: reflex-dom
2−Version: 0.5.3
3+Version: 0.6.1.0
34Synopsis: Functional Reactive Web Apps with Reflex
45Description:
5− Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine.
6+ Web applications without callbacks or side-effects.
7+ Reflex-DOM brings the power of functional reactive programming (FRP) to the web.
8+ Build HTML and other Document Object Model (DOM) data with a pure functional interface.
69 .
7− For hackage documentation, please see: <https://hackage.haskell.org/package/reflex-dom-core>.
10+ Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.
11+ .
12+ The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the
13+ correct set of dependencies for each target platform (GHCJS, WebKitGTK, WASM, mobile, etc.).
14+ Libraries should depend on @reflex-dom-core@ and executables will usually depend on @reflex-dom@.
15+ All of @reflex-dom-core@'s modules are re-exported by @reflex-dom@.
16+ .
17+ For Hackage documentation, please see: <https://hackage.haskell.org/package/reflex-dom-core>.
818License: BSD3
919License-file: LICENSE
1020Author: Ryan Trinkle
@@ -12,7 +22,6 @@ Maintainer: ryan.trinkle@gmail.com
1222Stability: Experimental
1323Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
1424Build-type: Simple
15−cabal-version: >=1.24
1625extra-source-files:
1726 java/org/reflexfrp/reflexdom/MainWidget.java
1827 ChangeLog.md
@@ -41,60 +50,67 @@ flag build-examples
4150 default: False
4251 manual: True
4352
53+flag wasm32
54+ description: Build for wasm32 architecture
55+ default: False
56+ manual: True
57+
4458library
4559 hs-source-dirs: src
4660 if os(android)
4761 hs-source-dirs: src-android
4862 other-modules: Reflex.Dom.Android.MainWidget
4963 build-depends:
50− aeson,
64+ aeson >= 1.4 && < 1.6,
5165 android-activity == 0.1.*,
5266 data-default == 0.7.*,
53− jsaddle
67+ jsaddle >= 0.9.6 && < 0.10
5468 c-sources: cbits/MainWidget.c
5569 include-dirs: cbits/include
5670 install-includes: MainWidget.h
5771 cpp-options: -DANDROID
5872 build-tools: hsc2hs
5973 build-depends:
60− base >= 4.7 && < 4.13,
74+ base >= 4.7 && < 4.15,
6175 bytestring == 0.10.*,
62− reflex >= 0.6.2 && < 0.8,
63− reflex-dom-core >=0.5.2 && < 0.6,
76+ reflex >= 0.8 && < 0.9,
77+ reflex-dom-core >= 0.6.1.0 && <0.7,
6478 text == 1.2.*
6579 if !impl(ghcjs)
6680 if flag(use-warp) && (os(linux) || os(osx))
6781 build-depends:
68− jsaddle,
69− jsaddle-warp
82+ jsaddle >= 0.9.6 && < 0.10,
83+ jsaddle-warp >= 0.9.6 && < 0.10
7084 else
7185 if os(osx) || os(ios)
7286 build-depends:
7387 data-default == 0.7.*,
74− jsaddle,
75− jsaddle-wkwebview
88+ jsaddle >= 0.9.6 && < 0.10,
89+ jsaddle-wkwebview >= 0.9.6 && < 0.10
7690 else
77− if arch(wasm32)
91+ if flag(wasm32)
7892 build-depends:
79− jsaddle,
80− jsaddle-wasm
93+ jsaddle >= 0.9.6 && < 0.10,
94+ jsaddle-wasm >= 0.1 && < 0.2
8195 else
8296 if flag(webkit2gtk)
8397 build-depends:
84− jsaddle-webkit2gtk
98+ jsaddle-webkit2gtk >= 0.9.6 && < 0.10
8599 else
86100 if !os(android)
87101 build-depends:
88− jsaddle-webkit2gtk
102+ jsaddle-webkit2gtk >= 0.9.6 && < 0.10
89103
90104 exposed-modules:
91105 Reflex.Dom
92106 Reflex.Dom.Internal
93107 reexported-modules:
94− Foreign.JavaScript.TH
95− , Foreign.JavaScript.Orphans
108+ Foreign.JavaScript.Orphans
109+ , Foreign.JavaScript.TH
110+ , Foreign.JavaScript.Utils
96111 , Reflex.Dom.Builder.Class
97112 , Reflex.Dom.Builder.Class.Events
113+ , Reflex.Dom.Builder.Hydratable
98114 , Reflex.Dom.Builder.Immediate
99115 , Reflex.Dom.Builder.InputDisabled
100116 , Reflex.Dom.Builder.Static
@@ -102,14 +118,19 @@ library
102118 , Reflex.Dom.Core
103119 , Reflex.Dom.Location
104120 , Reflex.Dom.Main
121+ , Reflex.Dom.Modals.Class
105122 , Reflex.Dom.Old
123+ , Reflex.Dom.Prerender
124+ , Reflex.Dom.Time
106125 , Reflex.Dom.WebSocket
126+ , Reflex.Dom.WebSocket.Query
107127 , Reflex.Dom.Widget
108128 , Reflex.Dom.Widget.Basic
109129 , Reflex.Dom.Widget.Input
110130 , Reflex.Dom.Widget.Lazy
111131 , Reflex.Dom.Widget.Resize
112132 , Reflex.Dom.Xhr
133+ , Reflex.Dom.Xhr.FormData
113134 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
114135 if flag(expose-all-unfoldings)
115136 ghc-options: -fexpose-all-unfoldings
@@ -141,7 +162,19 @@ executable sortableList
141162 default-language: Haskell2010
142163
143164executable benchmark
144− build-depends: base, reflex, reflex-dom, text, prim-uniq, dependent-map, containers, transformers, mtl, ghcjs-dom, ghc-prim, random, dependent-sum
165+ build-depends: base
166+ , containers
167+ , dependent-map
168+ , dependent-sum
169+ , ghc-prim
170+ , ghcjs-dom
171+ , mtl
172+ , prim-uniq
173+ , random
174+ , reflex
175+ , reflex-dom
176+ , text
177+ , transformers
145178 hs-source-dirs: .
146179 main-is: benchmark.hs
147180 ghc-options: -O2 -fspecialise-aggressively
@@ -150,7 +183,20 @@ executable benchmark
150183 default-language: Haskell2010
151184
152185executable krausest
153− build-depends: base, reflex, reflex-dom, text, prim-uniq, dependent-map, containers, transformers, mtl, ghcjs-dom, ghc-prim, random, dependent-sum, vector
186+ build-depends: base
187+ , containers
188+ , dependent-map
189+ , dependent-sum
190+ , ghc-prim
191+ , ghcjs-dom
192+ , mtl
193+ , prim-uniq
194+ , random
195+ , reflex
196+ , reflex-dom
197+ , text
198+ , transformers
199+ , vector
154200 hs-source-dirs: benchmarks
155201 main-is: krausest.hs
156202 ghc-options: -O2 -fspecialise-aggressively
release.nix+13−4
@@ -1,12 +1,14 @@
11{ reflex-platform-fun ? import ./dep/reflex-platform
2+, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
23}:
34
45let
56 native-reflex-platform = reflex-platform-fun {};
67 inherit (native-reflex-platform.nixpkgs) lib;
7− systems = ["x86_64-linux" "x86_64-darwin"];
88
9− perPlatform = lib.genAttrs systems (system: let
9+ tests = system: import ./test { pkgs = (reflex-platform-fun { inherit system; }).nixpkgs; };
10+
11+ perPlatform = lib.genAttrs supportedSystems (system: let
1012 reflex-platform = reflex-platform-fun { inherit system; };
1113 compilers = [
1214 "ghc"
@@ -25,15 +27,22 @@ let
2527 (self: super: {
2628 _dep = super._dep // {
2729 reflex-dom = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
28− "release.nix"
2930 ".git"
3031 "dist"
32+ "dist-newstyle"
33+ ]) && !(builtins.elem path [
34+ ./CONTRIBUTING.md
35+ ./FAQ.md
36+ ./Quickref.md
37+ ./README.md
38+ ./release.nix
39+ ./test
3140 ])) ./.;
3241 };
3342 })
3443 ];
3544 };
36− all = {
45+ all = tests system // {
3746 inherit (reflex-platform.${ghc})
3847 reflex-dom-core
3948 reflex-dom
test/default.nixnew file+10
@@ -0,0 +1,10 @@
1+{ pkgs ? (import ../dep/reflex-platform {}).nixpkgs }:
2+{
3+ test-reflex-dom-reexports = pkgs.runCommand "test-reflex-dom-reexports" {} (
4+ let
5+ ghc = pkgs.haskellPackages.ghcWithPackages (p: [p.Cabal]);
6+ in ''
7+ ${ghc}/bin/runhaskell ${./reflex-dom-reexports.hs} ${../reflex-dom/reflex-dom.cabal} ${../reflex-dom-core/reflex-dom-core.cabal}
8+ touch "$out"
9+ '');
10+}
test/prebuild.hsdeleted−127
@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−import Control.Monad
9−import Control.Monad.Identity
10−import Control.Monad.Trans
11−import Reflex.Dom
12−import qualified Data.Text as T
13−import Control.Concurrent
14−
15−import Control.Monad.State.Strict
16−import Data.Functor.Misc
17−import Data.Monoid
18−import Data.Word
19−import qualified Data.Map as Map
20−import qualified Data.Dependent.Map as DMap
21−import Data.Dependent.Sum
22−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
23−
24−main :: IO ()
25−main = mainWidget w
26−
27−w :: forall t m. (MonadWidget t m, DomRenderHook t m, MountableDomBuilder t m) => m ()
28−w = do
29− let slow :: forall m'. (MonadWidget t m', DomRenderHook t m') => m' ()
30− {-
31− performEventChain = do
32− postBuild <- delay 0 =<< getPostBuild
33− rec let maxN = 10000
34− n = leftmost [0 <$ postBuild, ffilter (<=maxN) $ succ <$> n']
35− n' <- performEvent $ return <$> n
36− pausedUntil $ ffilter (==maxN) n'
37− _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
38− return ()
39− -}
40−-- {- Many dyns
41− slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
42− where maxDepth = 6 :: Int
43− go 0 = blank
44− go n = void $ dyn $ pure $ do
45− let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"
46− s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor
47− elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n
48− elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
49− elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
50− elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
51−-- -}
52− {- Many elDynAttrs
53− slow = do
54− let size = 64
55− replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do
56− replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank
57− -}
58− {- Many dynTexts
59− slow = el "table" $ do
60− let size = 64
61− replicateM_ size $ el "tr" $ do
62− replicateM_ size $ el "td" $ do
63− dynText $ pure "."
64− -}
65− {- Many simultaneous performEvents
66− slow = do
67− postBuild <- getPostBuild
68− replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
69− done <- performEvent $ return () <$ postBuild
70− _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
71− return ()
72− -}
73− {-
74− slow = do
75− postBuild <- getPostBuild
76− postBuild' <- performEvent . (return () <$) =<< performEvent . (return () <$) =<< getPostBuild
77− let f x = Map.fromList [(n, x) | n <- [1 :: Int .. 4096]]
78− listHoldWithKey (f False) (f (Just True) <$ postBuild') $ \k -> \case
79− False -> do
80− text "X "
81− notReadyUntil =<< getPostBuild
82− True -> do
83− text ". "
84− return ()
85− -}
86− {-
87− slow = do
88− let f :: forall a. EitherTag () () a -> Const2 () () a -> m' (Const2 () () a)
89− f _ (Const2 ()) = do
90− notReadyUntil =<< delay 0.5 =<< getPostBuild
91− text "Done"
92− return $ Const2 ()
93− postBuild <- getPostBuild
94− traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild
95− return ()
96− -}
97− {-
98− slow = do
99− let h x = do
100− liftIO $ putStrLn "render hook"
101− result <- x
102− liftIO $ putStrLn "render hook done"
103− return result
104− f :: forall a. Const2 () () a -> Identity a -> m' (Identity a)
105− f (Const2 ()) (Identity ()) = do
106− liftIO $ putStrLn "f"
107− widgetHold notReady . (blank <$) =<< delay 0.1 =<< getPostBuild
108− liftIO $ putStrLn "f done"
109− return $ Identity ()
110− withRenderHook h $ do
111− postBuild <- getPostBuild
112− _ <- traverseDMapWithKeyWithAdjust f mempty $ PatchDMap (DMap.singleton (Const2 () :: Const2 () () ()) (ComposeMaybe $ Just $ Identity ())) <$ postBuild
113− return ()
114− -}
115− el "div" $ do
116− draw <- button "Draw"
117− widgetHold blank $ ffor draw $ \_ -> do
118− _ <- untilReady (text "Loading...") slow
119− return ()
120− return ()
121−
122−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
123−instance {-# INCOHERENT #-} (Show (f a), Show (f b)) => ShowTag (EitherTag a b) f where
124− showTagToShow e _ = case e of
125− LeftTag -> id
126− RightTag -> id
127−#endif
test/reflex-dom-reexports.hsnew file+72
@@ -0,0 +1,72 @@
1+-- This tests that reflex-dom re-exports all of reflex-dom-core's modules.
2+-- Without this test they easily drift.
3+module Main where
4+
5+import Control.Monad (when)
6+import Data.List (intercalate)
7+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
8+import qualified Data.Set as Set
9+import Distribution.Types.PackageName (mkPackageName)
10+import Distribution.Compiler (CompilerFlavor (GHC))
11+import Distribution.ModuleName (ModuleName, components)
12+import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
13+import qualified Distribution.Parsec.Common as Dist
14+import Distribution.Parsec.ParseResult (runParseResult)
15+import qualified Distribution.System as Dist
16+import Distribution.Types.BuildInfo (buildable, defaultExtensions, defaultLanguage, hsSourceDirs, options)
17+import Distribution.Types.CondTree (simplifyCondTree)
18+import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
19+import Distribution.Types.Library (exposedModules, libBuildInfo, reexportedModules)
20+import Distribution.Types.ModuleReexport (ModuleReexport, moduleReexportOriginalName, moduleReexportOriginalPackage)
21+import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
22+import System.Environment (getArgs)
23+import qualified System.Info
24+
25+main :: IO ()
26+main = do
27+ [reflexDomFile, reflexDomCoreFile] <- getArgs
28+ (_, reflexDomReexports) <- parseCabalExports reflexDomFile
29+ (reflexDomCoreExports', _) <- parseCabalExports reflexDomCoreFile
30+
31+ let
32+ reflexDomCoreExports = Set.fromList reflexDomCoreExports'
33+ reflexDomCorePackageName = mkPackageName "reflex-dom-core"
34+ reflexDomReexportsFromCore
35+ = Set.fromList
36+ $ mapMaybe (\x -> if let origPackage = moduleReexportOriginalPackage x
37+ in isNothing origPackage || origPackage == Just reflexDomCorePackageName
38+ then Just $ moduleReexportOriginalName x
39+ else Nothing
40+ )
41+ reflexDomReexports
42+
43+ when (reflexDomCoreExports /= reflexDomReexportsFromCore) $ do
44+ error $ intercalate "\n\t"
45+ $ "reflex-dom does not re-export the following modules from reflex-dom-core:"
46+ : map
47+ (intercalate "." . components)
48+ (Set.toAscList $ reflexDomCoreExports `Set.difference` reflexDomReexportsFromCore)
49+
50+ putStrLn "Test passed."
51+
52+parseCabalExports :: FilePath -> IO ([ModuleName], [ModuleReexport])
53+parseCabalExports file = do
54+ contents <- readUTF8File file
55+ let
56+ (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS contents
57+ osConfVar = case System.Info.os of
58+ "linux" -> Just Dist.Linux
59+ "darwin" -> Just Dist.OSX
60+ _ -> error "Unrecognized System.Info.os"
61+ archConfVar = Just Dist.X86_64
62+ evalConfVar v = Right $ case v of
63+ OS osVar -> Just osVar == osConfVar
64+ Arch archVar -> Just archVar == archConfVar
65+ Impl GHC _ -> True
66+ _ -> False
67+ pure $ case condLibrary <$> result of
68+ Right (Just condLib) ->
69+ let (_, lib) = simplifyCondTree evalConfVar condLib
70+ in (exposedModules lib, reexportedModules lib)
71+ Right Nothing -> error $ "Haskell package has no library component: " <> file
72+ Left (_, errors) -> error $ "Failed to parse " <> file <> ":\n" <> unlines (map show errors)