git.iko.soy/reflex-dom
on develop help sign in
swap
2236067192 ahead, 0 behind
45 files changed+1364−355
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+51−27 reflex-dom-core/LICENSE+1−1 reflex-dom-core/reflex-dom-core.cabal+44−21 reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+11−2 reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+13−2 reflex-dom-core/src/Reflex/Dom/Builder/Hydratable.hs+4−4 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+118−34 reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+35−10 reflex-dom-core/src/Reflex/Dom/Class.hs+4−7 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/src/Reflex/Dom/Xhr.hs+8−6 reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+2−2 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+20 reflex-dom/LICENSE+1−1 reflex-dom/benchmark.hs+2−1 reflex-dom/reflex-dom.cabal+72−21 reflex-dom/src/Reflex/Dom/Internal.hs+5 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+51−27
@@ -1,42 +1,66 @@
11# Revision history for reflex-dom-core
22
3−## Unreleased
3+## 0.6.2.1
44
5−* Support GHC 8.8.
5+* Fix hlint complaints with newer GHC.
66
7−* Fix attribute support for explicitly namespaced elements
7+## 0.6.2.0
88
9−* Remove deprecation warnings for the following widgets in
10− `Reflex.Dom.Widget.Basic`:
9+* ([#400](https://github.com/reflex-frp/reflex-dom/pull/400/files)) Set value of input elements in static renderer
1110
12− * `Link`
13− * `button`
14− * `dtdd`
15− * `linkClass`
16− * `link`
17− * `tabDisplay`
18− * `tableDynAttr`
11+## 0.6.1.0
1912
20−## 0.5.3
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`
2120
22−* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:
2321
24− * `Link`
25− * `button`
26− * `dtdd`
27− * `linkClass`
28− * `link`
29− * `tabDisplay`
30− * `tableDynAttr`
22+## 0.6.0.0
3123
32− And in `Reflex.Dom.Widget.Input`:
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.
29+* ([#353](https://github.com/reflex-frp/reflex-dom/pull/353)) Support GHC 8.8.
30+* ([#358](https://github.com/reflex-frp/reflex-dom/pull/358)) Fix attribute support for explicitly namespaced elements.
31+* ([#363](https://github.com/reflex-frp/reflex-dom/pull/363)) Remove deprecation warnings for the following widgets in
32+ `Reflex.Dom.Widget.Basic`:
33+ * `Link`
34+ * `button`
35+ * `dtdd`
36+ * `linkClass`
37+ * `link`
38+ * `tabDisplay`
39+ * `tableDynAttr`
40+* ([#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.
42+* ([#364](https://github.com/reflex-frp/reflex-dom/pull/364)) Export attributes used for controlling hydration at the element level:
43+ * "data-ssr" is now available as `Reflex.Dom.Builder.Immediate.hydratableAttribute`.
44+ * "data-hydration-skip" is now available as `Reflex.Dom.Builder.Immediate.skipHydrationAttribute`.
45+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
3346
34− * `TextInput`
35− * `TextAreaConfig`
36− * `CheckboxConfig`
37− * `FileInput`
47+## 0.5.3
48+
49+* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:
50+ * `Link`
51+ * `button`
52+ * `dtdd`
53+ * `linkClass`
54+ * `link`
55+ * `tabDisplay`
56+ * `tableDynAttr`
3857
39− * Add `< 0.7` upper bound for reflex
58+ And in `Reflex.Dom.Widget.Input`:
59+ * `TextInput`
60+ * `TextAreaConfig`
61+ * `CheckboxConfig`
62+ * `FileInput`
63+* Add `< 0.7` upper bound for `reflex`.
4064
4165## 0.5.2
4266
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+44−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,21 +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.*,
76+ case-insensitive < 1.3,
5677 containers >= 0.6 && < 0.7,
57− constraints >= 0.9 && < 0.12,
78+ constraints >= 0.9 && < 0.13,
5879 contravariant >= 1.4 && < 1.6,
5980 data-default >= 0.5 && < 0.8,
60− dependent-map >= 0.3 && < 0.4,
61− dependent-sum >= 0.6 && < 0.7,
81+ dependent-map >= 0.3 && < 0.5,
82+ dependent-sum >= 0.6 && < 0.8,
6283 dependent-sum-template >= 0.1 && < 0.2,
6384 directory >= 1.2 && < 1.4,
6485 exception-transformers == 0.4.*,
@@ -70,9 +91,9 @@ library
7091 monad-control >= 1.0.1 && < 1.1,
7192 mtl >= 2.1 && < 2.3,
7293 primitive >= 0.5 && < 0.8,
73− random,
94+ random >= 1.1 && < 1.2,
7495 ref-tf == 0.4.*,
75− reflex >= 0.6.2 && < 0.7,
96+ reflex >= 0.8 && < 0.9,
7697 semigroups >= 0.16 && < 0.20,
7798 stm >= 2.4 && < 2.6,
7899 text == 1.2.*,
@@ -93,7 +114,7 @@ library
93114 if flag(split-these)
94115 build-depends:
95116 semialign >= 1 && < 1.2,
96− these >= 1 && < 1.1
117+ these >= 1 && < 1.2
97118 else
98119 build-depends:
99120 these >= 0.4 && < 0.9
@@ -132,6 +153,7 @@ library
132153 Reflex.Dom.Xhr.ResponseType
133154 Reflex.Dom.Xhr.Exception
134155
156+ default-language: Haskell98
135157 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively
136158 ghc-prof-options: -fprof-auto
137159
@@ -146,22 +168,21 @@ library
146168
147169 if flag(use-template-haskell)
148170 build-depends:
149− dependent-sum >= 0.6,
150171 dependent-sum-template >= 0.1 && < 0.2,
151− template-haskell
172+ template-haskell >= 2.12.0 && < 2.17
152173 other-extensions: TemplateHaskell
153174 cpp-options: -DUSE_TEMPLATE_HASKELL
154175 other-modules:
155176 Reflex.Dom.Builder.Class.TH
156− else
157− build-depends:
158− dependent-sum == 0.6.*
159177
160178test-suite hlint
161− build-depends: base, hlint
179+ build-depends:
180+ base,
181+ hlint >= 2.0 && < 4.0
162182 hs-source-dirs: test
163183 main-is: hlint.hs
164184 type: exitcode-stdio-1.0
185+ default-language: Haskell98
165186
166187test-suite hydration
167188 build-depends: base
@@ -208,7 +229,8 @@ test-suite hydration
208229 ghc-prof-options: -fprof-auto -optP-DPROFILING
209230 main-is: hydration.hs
210231 type: exitcode-stdio-1.0
211− 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)
212234 buildable: False
213235
214236-- broken test on base 4.11 & ghc 8.4.3
@@ -227,7 +249,8 @@ test-suite gc
227249 ghc-prof-options: -fprof-auto -optP-DPROFILING
228250 main-is: gc.hs
229251 type: exitcode-stdio-1.0
230− if !os(linux) || !arch(x86_64)
252+ default-language: Haskell98
253+ if !os(linux) || !arch(x86_64) || !flag(gc-tests)
231254 buildable: False
232255
233256source-repository head
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+11−2
@@ -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 #-}
@@ -638,7 +639,7 @@ instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive
638639
639640-- * Convenience functions
640641
641−class HasDomEvent t target eventName where
642+class HasDomEvent t target eventName | target -> t where
642643 type DomEventType target eventName :: *
643644 domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)
644645
@@ -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+13−2
@@ -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 = ()
@@ -159,7 +160,17 @@ type family EventResultType (en :: EventTag) :: * where
159160 EventResultType 'TouchmoveTag = TouchEventResult
160161 EventResultType 'TouchendTag = TouchEventResult
161162 EventResultType 'TouchcancelTag = TouchEventResult
162− EventResultType 'WheelTag = ()
163+ EventResultType 'WheelTag = WheelEventResult
164+
165+data DeltaMode = DeltaPixel | DeltaLine | DeltaPage
166+ deriving (Show, Read, Eq, Ord, Bounded, Enum)
167+
168+data WheelEventResult = WheelEventResult
169+ { _wheelEventResult_deltaX :: Double
170+ , _wheelEventResult_deltaY :: Double
171+ , _wheelEventResult_deltaZ :: Double
172+ , _wheelEventResult_deltaMode :: DeltaMode
173+ } deriving (Show, Read, Eq, Ord)
163174
164175data TouchEventResult = TouchEventResult
165176 { _touchEventResult_altKey :: Bool
reflex-dom-core/src/Reflex/Dom/Builder/Hydratable.hs+4−4
@@ -21,10 +21,10 @@ import GHCJS.DOM.Types (MonadJSM (..))
2121#endif
2222import Reflex
2323import Reflex.Dom.Builder.Class
24−import Reflex.Dom.Builder.Immediate (HasDocument (..))
24+import Reflex.Dom.Builder.Immediate (HasDocument (..), hydratableAttribute)
2525import Reflex.Host.Class
2626
27−-- | A DomBuilder transformer that adds "data-ssr" to all elements such that the
27+-- | A DomBuilder transformer that adds an attribute to all elements such that the
2828-- hydration builder knows which bits of DOM were added by us, and which were
2929-- added by external scripts.
3030newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
@@ -62,8 +62,8 @@ instance PrimMonad m => PrimMonad (HydratableT m) where
6262
6363makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m
6464makeHydratable cfg = cfg
65− { _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg
66− , _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg
65+ { _elementConfig_initialAttributes = Map.insert hydratableAttribute "" $ _elementConfig_initialAttributes cfg
66+ , _elementConfig_modifyAttributes = fmap (Map.delete hydratableAttribute) <$> _elementConfig_modifyAttributes cfg
6767 }
6868
6969instance PostBuild t m => PostBuild t (HydratableT m) where
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+118−34
@@ -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
@@ -107,6 +107,9 @@ module Reflex.Dom.Builder.Immediate
107107 , WindowConfig (..)
108108 , Window (..)
109109 , wrapWindow
110+ -- * Attributes for controlling hydration
111+ , hydratableAttribute
112+ , skipHydrationAttribute
110113 -- * Internal
111114 , traverseDMapWithKeyWithAdjust'
112115 , hoistTraverseWithKeyWithAdjust
@@ -132,14 +135,18 @@ import Data.Functor.Compose
132135import Data.Functor.Constant
133136import Data.Functor.Misc
134137import Data.Functor.Product
138+import Data.GADT.Compare (GCompare)
135139import Data.IORef
136140import Data.IntMap.Strict (IntMap)
137141import Data.Maybe
138142import Data.Monoid ((<>))
139143import Data.Some (Some(..))
144+import Data.GADT.Compare (GCompare)
145+import Data.String (IsString)
140146import Data.Text (Text)
141147import Foreign.JavaScript.Internal.Utils
142148import Foreign.JavaScript.TH
149+import GHCJS.DOM.ClipboardEvent as ClipboardEvent
143150import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
144151import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
145152import GHCJS.DOM.EventM (EventM, event, on)
@@ -175,6 +182,7 @@ import qualified Data.IntMap.Strict as IntMap
175182import qualified Data.Map as Map
176183import qualified Data.Text as T
177184import qualified GHCJS.DOM as DOM
185+import qualified GHCJS.DOM.DataTransfer as DataTransfer
178186import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
179187import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
180188import qualified GHCJS.DOM.Element as Element
@@ -192,6 +200,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
192200import qualified GHCJS.DOM.TouchList as TouchList
193201import qualified GHCJS.DOM.Types as DOM
194202import qualified GHCJS.DOM.Window as Window
203+import qualified GHCJS.DOM.WheelEvent as WheelEvent
195204import qualified Reflex.Patch.DMap as PatchDMap
196205import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197206import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -285,12 +294,21 @@ localRunner (HydrationRunnerT m) s parent = do
285294runHydrationRunnerT
286295 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
287296 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
288−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
289304 (a, s') <- runStateT m (HydrationState s False)
290305 traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
291306 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
292308 pure a
293309
310+
311+
294312instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
295313 {-# INLINABLE newEventWithTrigger #-}
296314 newEventWithTrigger = lift . newEventWithTrigger
@@ -314,12 +332,11 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
314332-- done *before* the switchover to immediate mode - this is most likely some
315333-- form of 'hold' which we want to remove after hydration is done
316334{-# INLINABLE addHydrationStepWithSetup #-}
317−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 ()
318336addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319337 HydrationMode_Immediate -> pure ()
320338 HydrationMode_Hydrating -> do
321− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
339+ s <- lift setup
323340 addHydrationStep (f s)
324341
325342-- | Add a hydration step
@@ -743,6 +760,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
743760 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
744761 #-}
745762
763+-- | An attribute which causes hydration to skip over an element completely.
764+skipHydrationAttribute :: IsString s => s
765+skipHydrationAttribute = "data-hydration-skip"
766+
767+-- | An attribute which signals that an element should be hydrated.
768+hydratableAttribute :: IsString s => s
769+hydratableAttribute = "data-ssr"
770+
746771{-# INLINE hydrateElement #-}
747772hydrateElement
748773 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
@@ -764,13 +789,15 @@ hydrateElement elementTag cfg child = do
764789 }
765790 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
766791 wrapResult <- liftIO newEmptyMVar
767− let skipAttr = "data-hydration-skip" :: DOM.JSString
768− ssrAttr = "data-ssr" :: DOM.JSString
792+ let -- Determine if we should skip an element. We currently skip elements for
793+ -- two reasons:
794+ -- 1) it was not produced by a static builder which supports hydration
795+ -- 2) it is explicitly marked to be skipped
769796 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
770797 shouldSkip e = do
771− skip <- hasAttribute e skipAttr
772− ssr <- hasAttribute e ssrAttr
773− pure $ skip || not ssr
798+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
799+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
800+ pure $ skip || not hydratable
774801 childDom <- liftIO $ readIORef childDelayedRef
775802 let rawCfg = extractRawElementConfig cfg
776803 doc <- askDocument
@@ -786,7 +813,7 @@ hydrateElement elementTag cfg child = do
786813 Just node -> DOM.castTo DOM.Element node >>= \case
787814 Nothing -> go (Just node) -- this node is not an element, skip
788815 Just e -> shouldSkip e >>= \case
789− True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
816+ True -> go (Just node) -- this element should be skipped by hydration
790817 False -> do
791818 t <- Element.getTagName e
792819 -- TODO: check attributes?
@@ -910,14 +937,26 @@ inputElementInternal cfg = getHydrationMode >>= \case
910937 doc <- askDocument
911938 -- Expected initial value from config
912939 let v0 = _inputElementConfig_initialValue cfg
913− 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'
914948 domElement <- liftIO $ readIORef domElementRef
915949 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
916950 getValue = Input.getValue domInputElement
917− -- The browser might have messed with the value, or the user could have
918− -- altered it before activation, so we set it if it isn't what we expect
919− liftJSM getValue >>= \v0' -> do
920− 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
921960 -- Watch for user interaction and trigger event accordingly
922961 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
923962 for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
@@ -931,7 +970,17 @@ inputElementInternal cfg = getHydrationMode >>= \case
931970 ]
932971 liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
933972 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
934− 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
935984 _ <- liftJSM $ domInputElement `on` Events.click $ do
936985 liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
937986 for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
@@ -944,7 +993,7 @@ inputElementInternal cfg = getHydrationMode >>= \case
944993 let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
945994 liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
946995 return ()
947− checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
996+ checked' <- holdDyn c0 $ leftmost
948997 [ checkedChangedBySetChecked
949998 , checkedChangedByUI
950999 ]
@@ -1016,14 +1065,21 @@ textAreaElementInternal cfg = getHydrationMode >>= \case
10161065 doc <- askDocument
10171066 -- Expected initial value from config
10181067 let v0 = _textAreaElementConfig_initialValue cfg
1019− addHydrationStep $ do
1068+ valueAtSwitchover = maybe (pure $ pure v0) (hold v0) (_textAreaElementConfig_setValue cfg)
1069+ addHydrationStepWithSetup valueAtSwitchover $ \switchoverValue' -> do
1070+ switchoverValue <- sample switchoverValue'
10201071 domElement <- liftIO $ readIORef domElementRef
10211072 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
10221073 getValue = TextArea.getValue domTextAreaElement
1023− -- The browser might have messed with the value, or the user could have
1024− -- altered it before activation, so we set it if it isn't what we expect
1025− liftJSM getValue >>= \v0' -> do
1026− 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
10271083 -- Watch for user interaction and trigger event accordingly
10281084 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
10291085 for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
@@ -1291,13 +1347,12 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12911347 go Nothing _ = do
12921348 tn <- createTextNode doc ("" :: Text)
12931349 insertAfterPreviousNode tn
1350+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
12941351 pure (tn, Nothing)
12951352 go (Just key0) mLastNode = do
12961353 parent <- askParent
12971354 maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1298− Nothing -> do
1299− HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1300− go Nothing Nothing
1355+ Nothing -> go Nothing Nothing
13011356 Just node -> DOM.castTo DOM.Comment node >>= \case
13021357 Just comment -> do
13031358 commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
@@ -1617,7 +1672,7 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ra
16171672
16181673{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
16191674traverseDMapWithKeyWithAdjust'
1620− :: 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)
16211676 => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
16221677 -> DMap k v
16231678 -> Event t (PatchDMap k v)
@@ -1737,7 +1792,7 @@ hoistTraverseWithKeyWithAdjust
17371792 ::
17381793 ( Adjustable t m
17391794 , MonadHold t m
1740− , DMap.GCompare k
1795+ , GCompare k
17411796 , MonadIO m
17421797 , MonadJSM m
17431798 , PrimMonad m
@@ -1821,14 +1876,14 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
18211876 getHydrationMode >>= \case
18221877 HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
18231878 dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1824− 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
18251880 liftIO $ writeIORef placeholders $! phs
18261881 insertAfterPreviousNode lastPlaceholder
18271882 HydrationMode_Immediate -> do
18281883 let activate i = do
18291884 append $ toNode $ _traverseChildImmediate_fragment i
18301885 pure $ _traverseChildImmediate_placeholder i
1831− phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1886+ phs <- sequenceA $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
18321887 liftIO $ writeIORef placeholders $! phs
18331888 append $ toNode lastPlaceholder
18341889 requestDomAction_ $ ffor children' $ \p -> do
@@ -2242,7 +2297,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22422297 Beforecopy -> return ()
22432298 Copy -> return ()
22442299 Beforepaste -> return ()
2245− Paste -> return ()
2300+ Paste -> getPasteData
22462301 Reset -> return ()
22472302 Search -> return ()
22482303 Selectstart -> return ()
@@ -2251,7 +2306,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22512306 Touchend -> getTouchEvent
22522307 Touchcancel -> getTouchEvent
22532308 Mousewheel -> return ()
2254− Wheel -> return ()
2309+ Wheel -> getWheelEvent
22552310
22562311{-# INLINABLE defaultDomWindowEventHandler #-}
22572312defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2292,7 +2347,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22922347 Beforecopy -> return ()
22932348 Copy -> return ()
22942349 Beforepaste -> return ()
2295− Paste -> return ()
2350+ Paste -> getPasteData
22962351 Reset -> return ()
22972352 Search -> return ()
22982353 Selectstart -> return ()
@@ -2301,7 +2356,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
23012356 Touchend -> getTouchEvent
23022357 Touchcancel -> getTouchEvent
23032358 Mousewheel -> return ()
2304− Wheel -> return ()
2359+ Wheel -> getWheelEvent
23052360
23062361{-# INLINABLE withIsEvent #-}
23072362withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2569,6 +2624,15 @@ getMouseEventCoords = do
25692624 e <- event
25702625 bisequence (getClientX e, getClientY e)
25712626
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+
25722636{-# INLINABLE getTouchEvent #-}
25732637getTouchEvent :: EventM e TouchEvent TouchEventResult
25742638getTouchEvent = do
@@ -2610,6 +2674,26 @@ getTouchEvent = do
26102674 , _touchEventResult_touches = touches
26112675 }
26122676
2677+{-# INLINABLE getWheelEvent #-}
2678+getWheelEvent :: EventM e WheelEvent WheelEventResult
2679+getWheelEvent = do
2680+ e <- event
2681+ dx :: Double <- WheelEvent.getDeltaX e
2682+ dy :: Double <- WheelEvent.getDeltaY e
2683+ dz :: Double <- WheelEvent.getDeltaZ e
2684+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2685+ return $ WheelEventResult
2686+ { _wheelEventResult_deltaX = dx
2687+ , _wheelEventResult_deltaY = dy
2688+ , _wheelEventResult_deltaZ = dz
2689+ , _wheelEventResult_deltaMode = case deltaMode of
2690+ 0 -> DeltaPixel
2691+ 1 -> DeltaLine
2692+ 2 -> DeltaPage
2693+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
2694+ _ -> error "getWheelEvent: impossible encoding"
2695+ }
2696+
26132697instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26142698 {-# INLINABLE sample #-}
26152699 sample = lift . sample
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/Class.hs+4−7
@@ -4,8 +4,7 @@ module Reflex.Dom.Class ( module Reflex.Dom.Class
44 , module Web.KeyCode
55 ) where
66
7−import Data.Map (Map)
8−import qualified Data.Map as Map
7+import Control.Lens
98import Reflex.Class
109import Web.KeyCode
1110
@@ -13,11 +12,9 @@ import Foreign.JavaScript.TH
1312import Reflex.PerformEvent.Class
1413import Reflex.PostBuild.Class
1514
16−import Prelude hiding (concat, mapM, mapM_, sequence)
17−
18−-- | Alias for Data.Map.singleton
19−(=:) :: k -> a -> Map k a
20−(=:) = Map.singleton
15+-- | Previously an alias for 'Data.Map.singleton', but now generalised to 'At'
16+(=:) :: (At m, Monoid m) => Index m -> IxValue m -> m
17+k =: a = at k ?~ a $ mempty
2118infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6
2219
2320{-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
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/src/Reflex/Dom/Xhr.hs+8−6
@@ -159,6 +159,8 @@ import Data.Aeson.Text
159159import Data.Aeson.Encode
160160#endif
161161import qualified Data.ByteString.Lazy as BL
162+import Data.CaseInsensitive (CI)
163+import qualified Data.CaseInsensitive as CI
162164import Data.Default
163165import qualified Data.List as L
164166import Data.Map (Map)
@@ -198,12 +200,12 @@ data XhrResponse
198200 , _xhrResponse_statusText :: Text
199201 , _xhrResponse_response :: Maybe XhrResponseBody
200202 , _xhrResponse_responseText :: Maybe Text
201− , _xhrResponse_headers :: Map Text Text
203+ , _xhrResponse_headers :: Map (CI Text) Text
202204 }
203205 deriving (Typeable)
204206
205207data XhrResponseHeaders =
206− OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response
208+ OnlyHeaders (Set.Set (CI Text)) -- ^ Parse a subset of headers from the XHR Response
207209 | AllHeaders -- ^ Parse all headers from the XHR Response
208210 deriving (Show, Read, Eq, Ord, Typeable)
209211
@@ -275,7 +277,7 @@ newXMLHttpRequestWithError req cb = do
275277 AllHeaders -> parseAllHeadersString <$>
276278 xmlHttpRequestGetAllResponseHeaders xhr
277279 OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
278− (Map.fromSet id xs)
280+ (Map.fromSet CI.original xs)
279281 _ <- liftJSM $ cb $ Right
280282 XhrResponse { _xhrResponse_status = status
281283 , _xhrResponse_statusText = statusText
@@ -288,10 +290,10 @@ newXMLHttpRequestWithError req cb = do
288290 return ()
289291 return xhr
290292
291−parseAllHeadersString :: Text -> Map Text Text
293+parseAllHeadersString :: Text -> Map (CI Text) Text
292294parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
293295 L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
294− where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
296+ where stripBoth (txt1, txt2) = (CI.mk $ T.strip txt1, T.strip $ T.drop 1 txt2)
295297
296298newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
297299newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
@@ -444,7 +446,7 @@ xhrResponse_responseText :: Lens' XhrResponse (Maybe Text)
444446xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4
445447{-# INLINE xhrResponse_responseText #-}
446448
447−xhrResponse_headers :: Lens' XhrResponse (Map Text Text)
449+xhrResponse_headers :: Lens' XhrResponse (Map (CI Text) Text)
448450xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5
449451{-# INLINE xhrResponse_headers #-}
450452
reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+2−2
@@ -15,7 +15,7 @@ import Data.Text (Text)
1515import Data.ByteString (ByteString)
1616import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
1717import GHCJS.DOM.Enums
18−import GHCJS.DOM.EventM (EventM, on)
18+import GHCJS.DOM.EventM (EventM, on, onSync)
1919import GHCJS.DOM.EventTarget (dispatchEvent)
2020import GHCJS.DOM.Types (MonadJSM, ToJSString, FormData, Document, Blob (..), ArrayBuffer (..), JSVal, JSM, IsEvent, XMLHttpRequestProgressEvent, ProgressEvent, Event, XMLHttpRequestUpload, FromJSString, ArrayBufferView (..), liftJSM, castTo)
2121import GHCJS.DOM.XMLHttpRequest
@@ -114,7 +114,7 @@ xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent
114114xmlHttpRequestOntimeout = (`on` timeout)
115115
116116xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())
117−xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
117+xmlHttpRequestOnreadystatechange = (`onSync` readyStateChange)
118118
119119xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m ()
120120xmlHttpRequestSetTimeout = setTimeout
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+20
@@ -1,5 +1,25 @@
11# Revision history for reflex-dom
22
3+## 0.6.1.0-r1
4+
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`
21+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
22+
323## 0.5.3
424
525* On Android, enable prompting the user for geolocation
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+72−21
@@ -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,55 +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.7,
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 flag(webkit2gtk)
91+ if flag(wasm32)
7892 build-depends:
79− jsaddle-webkit2gtk
93+ jsaddle >= 0.9.6 && < 0.10,
94+ jsaddle-wasm >= 0.1 && < 0.2
8095 else
81− if !os(android)
96+ if flag(webkit2gtk)
8297 build-depends:
83− jsaddle-webkit2gtk
98+ jsaddle-webkit2gtk >= 0.9.6 && < 0.10
99+ else
100+ if !os(android)
101+ build-depends:
102+ jsaddle-webkit2gtk >= 0.9.6 && < 0.10
84103
85104 exposed-modules:
86105 Reflex.Dom
87106 Reflex.Dom.Internal
88107 reexported-modules:
89− Foreign.JavaScript.TH
90− , Foreign.JavaScript.Orphans
108+ Foreign.JavaScript.Orphans
109+ , Foreign.JavaScript.TH
110+ , Foreign.JavaScript.Utils
91111 , Reflex.Dom.Builder.Class
92112 , Reflex.Dom.Builder.Class.Events
113+ , Reflex.Dom.Builder.Hydratable
93114 , Reflex.Dom.Builder.Immediate
94115 , Reflex.Dom.Builder.InputDisabled
95116 , Reflex.Dom.Builder.Static
@@ -97,14 +118,19 @@ library
97118 , Reflex.Dom.Core
98119 , Reflex.Dom.Location
99120 , Reflex.Dom.Main
121+ , Reflex.Dom.Modals.Class
100122 , Reflex.Dom.Old
123+ , Reflex.Dom.Prerender
124+ , Reflex.Dom.Time
101125 , Reflex.Dom.WebSocket
126+ , Reflex.Dom.WebSocket.Query
102127 , Reflex.Dom.Widget
103128 , Reflex.Dom.Widget.Basic
104129 , Reflex.Dom.Widget.Input
105130 , Reflex.Dom.Widget.Lazy
106131 , Reflex.Dom.Widget.Resize
107132 , Reflex.Dom.Xhr
133+ , Reflex.Dom.Xhr.FormData
108134 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
109135 if flag(expose-all-unfoldings)
110136 ghc-options: -fexpose-all-unfoldings
@@ -136,7 +162,19 @@ executable sortableList
136162 default-language: Haskell2010
137163
138164executable benchmark
139− 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
140178 hs-source-dirs: .
141179 main-is: benchmark.hs
142180 ghc-options: -O2 -fspecialise-aggressively
@@ -145,7 +183,20 @@ executable benchmark
145183 default-language: Haskell2010
146184
147185executable krausest
148− 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
149200 hs-source-dirs: benchmarks
150201 main-is: krausest.hs
151202 ghc-options: -O2 -fspecialise-aggressively
reflex-dom/src/Reflex/Dom/Internal.hs+5
@@ -80,6 +80,11 @@ run jsm = do
8080 startMainWidget a startPage jsm
8181 }
8282 forever $ threadDelay 1000000000
83+#elif defined(wasm32_HOST_ARCH)
84+import qualified Language.Javascript.JSaddle.Wasm as Wasm (run)
85+import Language.Javascript.JSaddle (JSM)
86+run :: JSM () -> IO ()
87+run = Wasm.run 0
8388#else
8489import Language.Javascript.JSaddle.WebKitGTK (run)
8590#endif
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)