e5771e6...develop · reflex-dom

git.iko.soy/reflex-dom

on develop help sign in

.github/workflows/haskell.ymlnew file+47

since splitsnapshots

unifiedsplit

@@ -0,0 +1,47 @@

1+name: github-action

3+on: [push, pull_request]

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 @@

4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

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.

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 @@

1## [Reflex-DOM](https://reflex-frp.org)

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)

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.

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).

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).

8−

9−A summary of Reflex-DOM functions is available in the [quick reference](Quickref.md).

11**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**

9**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**

13### Additional resources

11### Additional resources

14−[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)

15−

16−[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)

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)

18+* [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)

20### Hacking

cabal.project+10−1

@@ -1 +1,10 @@

1+packages:

2+ reflex-dom-core/

3+ reflex-dom/

4+ chrome-test-utils/

1−packages: reflex-dom-core, reflex-dom, reflex-dom-test-selenium

5+ reflex-dom-test-selenium/

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/

5+package reflex-dom-core

6+ flags: -hydration-tests -gc-tests

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 @@

2All rights reserved.

4Redistribution 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 @@

1Name: chrome-test-utils

2−Version: 0.4

2+Version: 0.5

3Synopsis: Utilities to write headless Chromium tests

4License: BSD3

5License-file: LICENSE

chrome-test-utils/src/Test/Util/ChromeFlags.hs+1

@@ -1,6 +1,7 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Test.Util.ChromeFlags where

4+import Data.Semigroup

4import Data.Text

5import Data.Text

5import System.IO.Temp

6import System.IO.Temp

chrome-test-utils/src/Test/Util/UnshareNetwork.hs+2−2

@@ -4,8 +4,8 @@ import System.Linux.Namespaces

4import System.Posix

5import System.Process

7−unshareNetork :: IO ()

7+unshareNetwork :: IO ()

8−unshareNetork = do

8+unshareNetwork = do

9 uid <- getEffectiveUserID

10 unshare [User, Network]

11 writeUserMappings Nothing [UserMapping 0 uid 1]

dep/reflex-platform/default.nix+1−6

@@ -1,7 +1,2 @@

1# DO NOT HAND-EDIT THIS FILE

2−import ((import <nixpkgs> {}).fetchFromGitHub (

2+import (import ./thunk.nix)

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−))

dep/reflex-platform/github.json+4−3

@@ -1,7 +1,8 @@

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "master",

4+ "branch": "aa-bump-some",

5− "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",

5+ "private": false,

6− "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"

6+ "rev": "fd5acecb50474f795734db9fb924cc3b2fd2b508",

7+ "sha256": "0wsdd67g42klsf9n3pxb3pndjdz36nzf8gp7pfm8j6nyyy2qribk"

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+19

@@ -1,5 +1,24 @@

1# Revision history for reflex-dom-core

3+## 0.6.2.1

5+* Fix hlint complaints with newer GHC.

7+## 0.6.2.0

9+* ([#400](https://github.com/reflex-frp/reflex-dom/pull/400/files)) Set value of input elements in static renderer

10+

11+## 0.6.1.0

12+

13+* Bump version bounds

14+* Update for new dependent-map and dependent-sum version (after the "some" package split)

15+* Add `MonadAtomicRef` instance for `UnrunnableT`

16+* Fix ([#467](https://github.com/reflex-frp/reflex-dom/issues/467)): Prevent multiple firings of XHR response event

17+* Updates for GHC 8.10

18+* Move `HasSetValue` from Reflex.Dom.Widget.Input to Reflex.Dom.Builder.Class and add an instance for `TextAreaElementConfig`

19+* Add `now` to the `MonadHold` instance for `UnrunnableT`

20+

21+

3## 0.6.0.0

22## 0.6.0.0

5* ([#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`.

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`.

reflex-dom-core/LICENSE+1−1

@@ -1,4 +1,4 @@

2All rights reserved.

4Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

reflex-dom-core/examples/testScreenshot.hsdeleted−7

@@ -1,7 +0,0 @@

1−-- |

2−

3−module Main where

4−

5−import Reflex.Dom.Test.Screenshot

6−

7−main = createScreenshot (pure ())

reflex-dom-core/reflex-dom-core.cabal+29−27

@@ -1,8 +1,12 @@

1cabal-version: 1.24

2Name: reflex-dom-core

3−Version: 0.6.0.0

3+Version: 0.6.2.1

4Synopsis: Functional Reactive Web Apps with Reflex

5Description:

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+ .

6 Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.

10 Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.

7 .

11 .

8 The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the

12 The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the

@@ -50,31 +54,37 @@ flag split-these

50 manual: False

54 manual: False

51 default: True

55 default: True

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+

53library

67library

54 hs-source-dirs: src

68 hs-source-dirs: src

55 build-depends:

69 build-depends:

56− aeson >= 0.8 && < 1.5,

70+ aeson >= 0.8 && < 1.6,

57− base >= 4.7 && < 4.14,

71+ base >= 4.7 && < 4.15,

58 bifunctors >= 4.2 && < 6,

72 bifunctors >= 4.2 && < 6,

59− bimap >= 0.3 && < 0.4,

73+ bimap >= 0.3 && < 0.5,

60 blaze-builder >= 0.4.1 && < 0.5,

74 blaze-builder >= 0.4.1 && < 0.5,

61 bytestring == 0.10.*,

75 bytestring == 0.10.*,

62 case-insensitive < 1.3,

76 case-insensitive < 1.3,

63 containers >= 0.6 && < 0.7,

77 containers >= 0.6 && < 0.7,

64− constraints >= 0.9 && < 0.12,

78+ constraints >= 0.9 && < 0.13,

65 contravariant >= 1.4 && < 1.6,

79 contravariant >= 1.4 && < 1.6,

66 data-default >= 0.5 && < 0.8,

80 data-default >= 0.5 && < 0.8,

67− dependent-map >= 0.3 && < 0.4,

81+ dependent-map >= 0.3 && < 0.5,

68− dependent-sum >= 0.6 && < 0.7,

82+ dependent-sum >= 0.6 && < 0.8,

69 dependent-sum-template >= 0.1 && < 0.2,

83 dependent-sum-template >= 0.1 && < 0.2,

70 directory >= 1.2 && < 1.4,

84 directory >= 1.2 && < 1.4,

71 exception-transformers == 0.4.*,

85 exception-transformers == 0.4.*,

72 ghcjs-dom >= 0.9.1.0 && < 0.10,

86 ghcjs-dom >= 0.9.1.0 && < 0.10,

73 jsaddle >= 0.9.0.0 && < 0.10,

87 jsaddle >= 0.9.0.0 && < 0.10,

74− process,

75− chrome-test-utils,

76− async,

77− jsaddle-warp,

78 -- keycode-0.2 has a bug on firefox

88 -- keycode-0.2 has a bug on firefox

79 keycode >= 0.2.1 && < 0.3,

89 keycode >= 0.2.1 && < 0.3,

80 lens >= 4.7 && < 5,

90 lens >= 4.7 && < 5,

@@ -83,13 +93,12 @@ library

83 primitive >= 0.5 && < 0.8,

93 primitive >= 0.5 && < 0.8,

84 random >= 1.1 && < 1.2,

94 random >= 1.1 && < 1.2,

85 ref-tf == 0.4.*,

95 ref-tf == 0.4.*,

86− reflex >= 0.6.2 && < 0.8,

96+ reflex >= 0.8 && < 0.9,

87 semigroups >= 0.16 && < 0.20,

97 semigroups >= 0.16 && < 0.20,

88 stm >= 2.4 && < 2.6,

98 stm >= 2.4 && < 2.6,

89 text == 1.2.*,

99 text == 1.2.*,

90 transformers >= 0.3 && < 0.6,

100 transformers >= 0.3 && < 0.6,

91 network-uri >= 2.6.1 && < 2.7,

101 network-uri >= 2.6.1 && < 2.7,

92− webdriver,

93 zenc == 0.1.*

102 zenc == 0.1.*

103

95 if impl(ghcjs)

104 if impl(ghcjs)

@@ -105,7 +114,7 @@ library

105 if flag(split-these)

114 if flag(split-these)

106 build-depends:

115 build-depends:

107 semialign >= 1 && < 1.2,

116 semialign >= 1 && < 1.2,

108− these >= 1 && < 1.1

117+ these >= 1 && < 1.2

109 else

118 else

110 build-depends:

119 build-depends:

111 these >= 0.4 && < 0.9

120 these >= 0.4 && < 0.9

@@ -127,7 +136,6 @@ library

127 Reflex.Dom.Modals.Class

136 Reflex.Dom.Modals.Class

128 Reflex.Dom.Old

137 Reflex.Dom.Old

129 Reflex.Dom.Prerender

138 Reflex.Dom.Prerender

130− Reflex.Dom.Test.Screenshot

131 Reflex.Dom.Time

139 Reflex.Dom.Time

132 Reflex.Dom.WebSocket

140 Reflex.Dom.WebSocket

133 Reflex.Dom.WebSocket.Query

141 Reflex.Dom.WebSocket.Query

@@ -161,14 +169,16 @@ library

161 if flag(use-template-haskell)

169 if flag(use-template-haskell)

162 build-depends:

170 build-depends:

163 dependent-sum-template >= 0.1 && < 0.2,

171 dependent-sum-template >= 0.1 && < 0.2,

164− template-haskell >= 2.12.0 && < 2.16

172+ template-haskell >= 2.12.0 && < 2.17

165 other-extensions: TemplateHaskell

173 other-extensions: TemplateHaskell

166 cpp-options: -DUSE_TEMPLATE_HASKELL

174 cpp-options: -DUSE_TEMPLATE_HASKELL

167 other-modules:

175 other-modules:

168 Reflex.Dom.Builder.Class.TH

176 Reflex.Dom.Builder.Class.TH

169

177

170test-suite hlint

178test-suite hlint

171− build-depends: base, hlint

179+ build-depends:

180+ base,

181+ hlint >= 2.0 && < 4.0

172 hs-source-dirs: test

182 hs-source-dirs: test

173 main-is: hlint.hs

183 main-is: hlint.hs

174 type: exitcode-stdio-1.0

184 type: exitcode-stdio-1.0

@@ -220,7 +230,7 @@ test-suite hydration

220 main-is: hydration.hs

230 main-is: hydration.hs

221 type: exitcode-stdio-1.0

231 type: exitcode-stdio-1.0

222 default-language: Haskell98

232 default-language: Haskell98

223− if !os(linux) || !arch(x86_64) || flag(profile-reflex)

233+ if !os(linux) || !arch(x86_64) || flag(profile-reflex) || !flag(hydration-tests)

224 buildable: False

234 buildable: False

225

235

226-- broken test on base 4.11 & ghc 8.4.3

236-- broken test on base 4.11 & ghc 8.4.3

@@ -240,18 +250,10 @@ test-suite gc

240 main-is: gc.hs

250 main-is: gc.hs

241 type: exitcode-stdio-1.0

251 type: exitcode-stdio-1.0

242 default-language: Haskell98

252 default-language: Haskell98

243− if !os(linux) || !arch(x86_64)

253+ if !os(linux) || !arch(x86_64) || !flag(gc-tests)

244 buildable: False

254 buildable: False

245

255

246source-repository head

256source-repository head

247 type: git

257 type: git

248 location: https://github.com/reflex-frp/reflex-dom

258 location: https://github.com/reflex-frp/reflex-dom

249 subdir: reflex-dom-core

259 subdir: reflex-dom-core

250−

251−executable testScreenshot

252− build-depends: base

253− , reflex-dom-core

254− hs-source-dirs: examples

255− main-is: testScreenshot.hs

256− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively

257− default-language: Haskell2010

reflex-dom-core/src/Foreign/JavaScript/TH.hs+1

@@ -82,6 +82,7 @@ import Control.Monad.Trans.Control

82import Data.ByteString (ByteString)

83import qualified Data.ByteString as BS

84import Data.Coerce (coerce)

85+import Data.Monoid

85import Data.Text (Text)

86import Data.Text (Text)

86import qualified Data.Text as T

87import qualified Data.Text as T

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+11−1

@@ -9,11 +9,12 @@

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10#if !MIN_VERSION_base(4,9,0)

11{-# LANGUAGE ImpredicativeTypes #-}

12+#else

13+{-# LANGUAGE Rank2Types #-} -- Implied by ImpredicativeTypes

12#endif

14#endif

13{-# LANGUAGE LambdaCase #-}

15{-# LANGUAGE LambdaCase #-}

14{-# LANGUAGE OverloadedStrings #-}

16{-# LANGUAGE OverloadedStrings #-}

15{-# LANGUAGE PolyKinds #-}

17{-# LANGUAGE PolyKinds #-}

16−{-# LANGUAGE Rank2Types #-}

17{-# LANGUAGE RecursiveDo #-}

18{-# LANGUAGE RecursiveDo #-}

18{-# LANGUAGE ScopedTypeVariables #-}

19{-# LANGUAGE ScopedTypeVariables #-}

19{-# LANGUAGE StandaloneDeriving #-}

20{-# LANGUAGE StandaloneDeriving #-}

@@ -56,6 +57,7 @@ import Data.Map (Map)

56import qualified Data.Map as Map

57import qualified Data.Map as Map

57import Data.Maybe

58import Data.Maybe

58import Data.Proxy

59import Data.Proxy

60+import Data.Semigroup

59import Data.String

61import Data.String

60import Data.Text (Text)

62import Data.Text (Text)

61import Data.Type.Coercion

63import Data.Type.Coercion

@@ -743,3 +745,11 @@ instance HasDocument m => HasDocument (DynamicWriterT t w m)

743instance HasDocument m => HasDocument (PostBuildT t m)

745instance HasDocument m => HasDocument (PostBuildT t m)

744instance HasDocument m => HasDocument (RequesterT t request response m)

746instance HasDocument m => HasDocument (RequesterT t request response m)

745instance HasDocument m => HasDocument (QueryT t q m)

747instance 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/Immediate.hs+60−21

@@ -2,7 +2,6 @@

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE ConstraintKinds #-}

4{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE DeriveFunctor #-}

6{-# LANGUAGE DeriveTraversable #-}

5{-# LANGUAGE DeriveTraversable #-}

7{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE EmptyDataDecls #-}

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

@@ -12,7 +11,6 @@

12{-# LANGUAGE LambdaCase #-}

11{-# LANGUAGE LambdaCase #-}

13{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

14{-# LANGUAGE OverloadedStrings #-}

13{-# LANGUAGE OverloadedStrings #-}

15−{-# LANGUAGE PackageImports #-}

16{-# LANGUAGE PatternGuards #-}

14{-# LANGUAGE PatternGuards #-}

17{-# LANGUAGE PolyKinds #-}

15{-# LANGUAGE PolyKinds #-}

18{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE RankNTypes #-}

@@ -50,6 +48,7 @@ module Reflex.Dom.Builder.Immediate

50 , HydrationMode (..)

48 , HydrationMode (..)

51 , HydrationRunnerT (..)

49 , HydrationRunnerT (..)

52 , runHydrationRunnerT

50 , runHydrationRunnerT

51+ , runHydrationRunnerTWithFailure

53 , ImmediateDomBuilderT

52 , ImmediateDomBuilderT

54 , runHydrationDomBuilderT

53 , runHydrationDomBuilderT

55 , getHydrationMode

54 , getHydrationMode

@@ -136,17 +135,19 @@ import Data.Functor.Compose

136import Data.Functor.Constant

135import Data.Functor.Constant

137import Data.Functor.Misc

136import Data.Functor.Misc

138import Data.Functor.Product

137import Data.Functor.Product

138+import Data.GADT.Compare (GCompare)

139import Data.IORef

140import Data.IntMap.Strict (IntMap)

141import Data.Maybe

142import Data.Monoid ((<>))

143import Data.Some (Some(..))

144+import Data.GADT.Compare (GCompare)

144import Data.String (IsString)

145import Data.String (IsString)

145import Data.Text (Text)

146import Data.Text (Text)

146import Foreign.JavaScript.Internal.Utils

147import Foreign.JavaScript.Internal.Utils

147import Foreign.JavaScript.TH

148import Foreign.JavaScript.TH

148import GHCJS.DOM.ClipboardEvent as ClipboardEvent

149import GHCJS.DOM.ClipboardEvent as ClipboardEvent

149−import "ghcjs-dom" GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

150+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

150import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)

151import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)

151import GHCJS.DOM.EventM (EventM, event, on)

152import GHCJS.DOM.EventM (EventM, event, on)

152import GHCJS.DOM.KeyboardEvent as KeyboardEvent

153import GHCJS.DOM.KeyboardEvent as KeyboardEvent

@@ -293,12 +294,21 @@ localRunner (HydrationRunnerT m) s parent = do

293runHydrationRunnerT

294runHydrationRunnerT

294 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))

295 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))

295 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

296 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

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

296−runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do

303+runHydrationRunnerTWithFailure (HydrationRunnerT m) onFailure s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do

297 (a, s') <- runStateT m (HydrationState s False)

304 (a, s') <- runStateT m (HydrationState s False)

298 traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'

305 traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'

299 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."

306 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

300 pure a

308 pure a

301

309

310+

311+

302instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where

312instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where

303 {-# INLINABLE newEventWithTrigger #-}

313 {-# INLINABLE newEventWithTrigger #-}

304 newEventWithTrigger = lift . newEventWithTrigger

314 newEventWithTrigger = lift . newEventWithTrigger

@@ -322,7 +332,7 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where

322-- done *before* the switchover to immediate mode - this is most likely some

332-- done *before* the switchover to immediate mode - this is most likely some

323-- form of 'hold' which we want to remove after hydration is done

333-- form of 'hold' which we want to remove after hydration is done

324{-# INLINABLE addHydrationStepWithSetup #-}

334{-# INLINABLE addHydrationStepWithSetup #-}

325−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 ()

326addHydrationStepWithSetup setup f = getHydrationMode >>= \case

336addHydrationStepWithSetup setup f = getHydrationMode >>= \case

327 HydrationMode_Immediate -> pure ()

337 HydrationMode_Immediate -> pure ()

328 HydrationMode_Hydrating -> do

338 HydrationMode_Hydrating -> do

@@ -927,14 +937,26 @@ inputElementInternal cfg = getHydrationMode >>= \case

927 doc <- askDocument

937 doc <- askDocument

928 -- Expected initial value from config

938 -- Expected initial value from config

929 let v0 = _inputElementConfig_initialValue cfg

939 let v0 = _inputElementConfig_initialValue cfg

930− 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'

931 domElement <- liftIO $ readIORef domElementRef

948 domElement <- liftIO $ readIORef domElementRef

932 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

949 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

933 getValue = Input.getValue domInputElement

950 getValue = Input.getValue domInputElement

934− -- The browser might have messed with the value, or the user could have

951+ -- When the value has been updated by setValue before switchover, we must

935− -- altered it before activation, so we set it if it isn't what we expect

952+ -- send an update here to remain in sync. This is because the later

936− liftJSM getValue >>= \v0' -> do

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.

937− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

959+ liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue

938 -- Watch for user interaction and trigger event accordingly

960 -- Watch for user interaction and trigger event accordingly

939 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

961 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

940 for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->

962 for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->

@@ -948,7 +970,17 @@ inputElementInternal cfg = getHydrationMode >>= \case

948 ]

970 ]

949 liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

971 liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

950 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

972 requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

951− 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

952 _ <- liftJSM $ domInputElement `on` Events.click $ do

984 _ <- liftJSM $ domInputElement `on` Events.click $ do

953 liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement

985 liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement

954 for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->

986 for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->

@@ -961,7 +993,7 @@ inputElementInternal cfg = getHydrationMode >>= \case

961 let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

993 let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

962 liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles

994 liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles

963 return ()

995 return ()

964− checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

996+ checked' <- holdDyn c0 $ leftmost

965 [ checkedChangedBySetChecked

997 [ checkedChangedBySetChecked

966 , checkedChangedByUI

998 , checkedChangedByUI

967 ]

999 ]

@@ -1033,14 +1065,21 @@ textAreaElementInternal cfg = getHydrationMode >>= \case

1033 doc <- askDocument

1065 doc <- askDocument

1034 -- Expected initial value from config

1066 -- Expected initial value from config

1035 let v0 = _textAreaElementConfig_initialValue cfg

1067 let v0 = _textAreaElementConfig_initialValue cfg

1036− addHydrationStep $ do

1068+ valueAtSwitchover = maybe (pure $ pure v0) (hold v0) (_textAreaElementConfig_setValue cfg)

1069+ addHydrationStepWithSetup valueAtSwitchover $ \switchoverValue' -> do

1070+ switchoverValue <- sample switchoverValue'

1037 domElement <- liftIO $ readIORef domElementRef

1071 domElement <- liftIO $ readIORef domElementRef

1038 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

1072 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

1039 getValue = TextArea.getValue domTextAreaElement

1073 getValue = TextArea.getValue domTextAreaElement

1040− -- The browser might have messed with the value, or the user could have

1074+ -- When the value has been updated by setValue before switchover, we must

1041− -- altered it before activation, so we set it if it isn't what we expect

1075+ -- send an update here to remain in sync. This is because the later

1042− liftJSM getValue >>= \v0' -> do

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.

1043− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

1082+ liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue

1044 -- Watch for user interaction and trigger event accordingly

1083 -- Watch for user interaction and trigger event accordingly

1045 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

1084 requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

1046 for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->

1085 for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->

@@ -1633,7 +1672,7 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ra

1633

1672

1634{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}

1673{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}

1635traverseDMapWithKeyWithAdjust'

1674traverseDMapWithKeyWithAdjust'

1636− :: 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)

1637 => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))

1676 => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))

1638 -> DMap k v

1677 -> DMap k v

1639 -> Event t (PatchDMap k v)

1678 -> Event t (PatchDMap k v)

@@ -1753,7 +1792,7 @@ hoistTraverseWithKeyWithAdjust

1753 ::

1792 ::

1754 ( Adjustable t m

1793 ( Adjustable t m

1755 , MonadHold t m

1794 , MonadHold t m

1756− , DMap.GCompare k

1795+ , GCompare k

1757 , MonadIO m

1796 , MonadIO m

1758 , MonadJSM m

1797 , MonadJSM m

1759 , PrimMonad m

1798 , PrimMonad m

@@ -1837,14 +1876,14 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

1837 getHydrationMode >>= \case

1876 getHydrationMode >>= \case

1838 HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

1877 HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

1839 dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children

1878 dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children

1840− 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

1841 liftIO $ writeIORef placeholders $! phs

1880 liftIO $ writeIORef placeholders $! phs

1842 insertAfterPreviousNode lastPlaceholder

1881 insertAfterPreviousNode lastPlaceholder

1843 HydrationMode_Immediate -> do

1882 HydrationMode_Immediate -> do

1844 let activate i = do

1883 let activate i = do

1845 append $ toNode $ _traverseChildImmediate_fragment i

1884 append $ toNode $ _traverseChildImmediate_fragment i

1846 pure $ _traverseChildImmediate_placeholder i

1885 pure $ _traverseChildImmediate_placeholder i

1847− phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0

1886+ phs <- sequenceA $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0

1848 liftIO $ writeIORef placeholders $! phs

1887 liftIO $ writeIORef placeholders $! phs

1849 append $ toNode lastPlaceholder

1888 append $ toNode lastPlaceholder

1850 requestDomAction_ $ ffor children' $ \p -> do

1889 requestDomAction_ $ ffor children' $ \p -> do

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+35−10

@@ -37,6 +37,7 @@ import Data.IntMap (IntMap)

37import qualified Data.IntMap as IntMap

38import qualified Data.Map as Map

39import Data.Map.Misc (applyMap)

40+import Data.Maybe (fromMaybe)

40import Data.Monoid ((<>))

41import Data.Monoid ((<>))

41import qualified Data.Set as Set

42import qualified Data.Set as Set

42import Data.Text (Text)

43import Data.Text (Text)

@@ -273,7 +274,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

273 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

274 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

274 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape

275 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape

275 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8

276 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8

276− modify . (:) =<< (\c -> "") <$> case mSetContents of

277+ (modify . (:)) . (\c -> "") =<< case mSetContents of

277 Nothing -> return (pure (escape initialContents))

278 Nothing -> return (pure (escape initialContents))

278 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on

279 Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on

279 return $ CommentNode ()

280 return $ CommentNode ()

@@ -311,13 +312,32 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

311 return (e, result)

312 return (e, result)

312 {-# INLINABLE inputElement #-}

313 {-# INLINABLE inputElement #-}

313 inputElement cfg = do

314 inputElement cfg = do

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

314− (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

330+ (e, _result) <- element "input" adjustedConfig $ return ()

331+ v <- case _inputElementConfig_setValue cfg of

332+ Nothing -> pure $ constDyn (cfg ^. inputElementConfig_initialValue)

315− let v0 = constDyn $ cfg ^. inputElementConfig_initialValue

333+ Just ev -> holdDyn (cfg ^. inputElementConfig_initialValue) ev

316− let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked

334+ c <- case _inputElementConfig_setChecked cfg of

335+ Nothing -> pure $ constDyn $ _inputElementConfig_initialChecked cfg

336+ Just ev -> holdDyn (_inputElementConfig_initialChecked cfg) ev

317 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes

337 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes

318 return $ InputElement

338 return $ InputElement

319− { _inputElement_value = v0

339+ { _inputElement_value = v

320− , _inputElement_checked = c0

340+ , _inputElement_checked = c

321 , _inputElement_checkedChange = never

341 , _inputElement_checkedChange = never

322 , _inputElement_input = never

342 , _inputElement_input = never

323 , _inputElement_hasFocus = hasFocus

343 , _inputElement_hasFocus = hasFocus

@@ -327,12 +347,17 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

327 }

347 }

328 {-# INLINABLE textAreaElement #-}

348 {-# INLINABLE textAreaElement #-}

329 textAreaElement cfg = do

349 textAreaElement cfg = do

330− --TODO: Support setValue event

331− (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

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)

332− let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue

357+ Just ev -> holdDyn (cfg ^. textAreaElementConfig_initialValue) ev

333 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes

358 let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes

334 return $ TextAreaElement

359 return $ TextAreaElement

335− { _textAreaElement_value = v0

360+ { _textAreaElement_value = v

336 , _textAreaElement_input = never

361 , _textAreaElement_input = never

337 , _textAreaElement_hasFocus = hasFocus

362 , _textAreaElement_hasFocus = hasFocus

338 , _textAreaElement_element = e

363 , _textAreaElement_element = e

reflex-dom-core/src/Reflex/Dom/Location.hs+1

@@ -26,6 +26,7 @@ import Control.Lens ((^.))

26import Control.Monad ((>=>))

27import Control.Monad.Fix (MonadFix)

28import Data.Align (align)

29+import Data.Monoid

29import Data.Text (Text)

30import Data.Text (Text)

30import Data.These (These(..))

31import Data.These (These(..))

31import qualified GHCJS.DOM as DOM

32import qualified GHCJS.DOM as DOM

reflex-dom-core/src/Reflex/Dom/Main.hs+38−9

@@ -5,8 +5,6 @@

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE NoMonomorphismRestriction #-}

8−{-# LANGUAGE PackageImports #-}

9−{-# LANGUAGE PatternSynonyms #-}

10{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RecursiveDo #-}

9{-# LANGUAGE RecursiveDo #-}

12{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

@@ -47,7 +45,7 @@ import Data.Text (Text)

47import qualified Data.Text as T

45import qualified Data.Text as T

48import Data.Text.Encoding

46import Data.Text.Encoding

49import GHCJS.DOM

47import GHCJS.DOM

50−import "ghcjs-dom" GHCJS.DOM.Document

48+import GHCJS.DOM.Document

51import GHCJS.DOM.Element

49import GHCJS.DOM.Element

52import GHCJS.DOM.Node

50import GHCJS.DOM.Node

53import GHCJS.DOM.NonElementParentNode

51import GHCJS.DOM.NonElementParentNode

@@ -74,8 +72,14 @@ mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverActio

74{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}

72{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}

75-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.

73-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.

76mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()

74mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()

77−mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = 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

78− runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do

82+ runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction $ \appendHead appendBody -> do

79 appendHead head'

83 appendHead head'

80 appendBody body

84 appendBody body

@@ -90,7 +94,21 @@ attachHydrationWidget

90 -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))

94 -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))

91 )

95 )

92 -> IO (a, FireCommand DomTimeline DomHost)

96 -> IO (a, FireCommand DomTimeline DomHost)

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)

93−attachHydrationWidget switchoverAction jsSing w = do

111+attachHydrationWidgetWithFailure onFailure switchoverAction jsSing w = do

94 hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating

112 hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating

95 rootNodesRef <- liftIO $ newIORef []

113 rootNodesRef <- liftIO $ newIORef []

96 events <- newChan

114 events <- newChan

@@ -106,7 +124,7 @@ attachHydrationWidget switchoverAction jsSing w = do

106 rootNodes <- liftIO $ readIORef rootNodesRef

124 rootNodes <- liftIO $ readIORef rootNodesRef

107 let delayedAction = do

125 let delayedAction = do

108 for_ (reverse rootNodes) $ \(rootNode, runner) -> do

126 for_ (reverse rootNodes) $ \(rootNode, runner) -> do

109− let hydrate = runHydrationRunnerT runner Nothing rootNode events

127+ let hydrate = runHydrationRunnerTWithFailure runner onFailure Nothing rootNode events

110 void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing

128 void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing

111 liftIO $ writeIORef hydrationMode HydrationMode_Immediate

129 liftIO $ writeIORef hydrationMode HydrationMode_Immediate

112 runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing

130 runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing

@@ -127,11 +145,22 @@ runHydrationWidgetWithHeadAndBody

127 -> FloatingWidget () ()

145 -> FloatingWidget () ()

128 )

146 )

129 -> JSM ()

147 -> JSM ()

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 ()

130−runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do

159+runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction app = withJSContextSingletonMono $ \jsSing -> do

131 globalDoc <- currentDocumentUnchecked

160 globalDoc <- currentDocumentUnchecked

132 headElement <- getHeadUnchecked globalDoc

161 headElement <- getHeadUnchecked globalDoc

133 bodyElement <- getBodyUnchecked globalDoc

162 bodyElement <- getBodyUnchecked globalDoc

134− (events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do

163+ (events, fc) <- liftIO . attachHydrationWidgetWithFailure onFailure switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do

135 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

164 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

136 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c

165 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c

137 hydrateDom n w = do

166 hydrateDom n w = do

reflex-dom-core/src/Reflex/Dom/Prerender.hs+7−5

@@ -7,7 +7,6 @@

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PackageImports #-}

11{-# LANGUAGE Rank2Types #-}

10{-# LANGUAGE Rank2Types #-}

12{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE RecursiveDo #-}

13{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

@@ -25,7 +24,7 @@ module Reflex.Dom.Prerender

26import Control.Monad.Primitive (PrimMonad(..))

25import Control.Monad.Primitive (PrimMonad(..))

27import Control.Monad.Reader

26import Control.Monad.Reader

28−import Control.Monad.Ref (MonadRef(..))

27+import Control.Monad.Ref (MonadRef(..), MonadAtomicRef(..))

29import Data.IORef (IORef, newIORef)

28import Data.IORef (IORef, newIORef)

30import Data.Semigroup (Semigroup)

29import Data.Semigroup (Semigroup)

31import Data.Text (Text)

30import Data.Text (Text)

@@ -42,7 +41,7 @@ import Reflex.Host.Class

42import Data.IntMap.Strict (IntMap)

41import Data.IntMap.Strict (IntMap)

43import qualified Data.IntMap.Strict as IntMap

42import qualified Data.IntMap.Strict as IntMap

45−import qualified "ghcjs-dom" GHCJS.DOM.Document as Document

44+import qualified GHCJS.DOM.Document as Document

46import qualified GHCJS.DOM.Node as Node

45import qualified GHCJS.DOM.Node as Node

47import qualified GHCJS.DOM.Types as DOM

46import qualified GHCJS.DOM.Types as DOM

@@ -166,6 +165,8 @@ instance Monad m => MonadRef (UnrunnableT js t m) where

166 newRef _ = unrunnable

165 newRef _ = unrunnable

167 readRef _ = unrunnable

166 readRef _ = unrunnable

168 writeRef _ _ = unrunnable

167 writeRef _ _ = unrunnable

168+instance Monad m => MonadAtomicRef (UnrunnableT js t m) where

169+ atomicModifyRef _ _ = unrunnable

169instance Monad m => HasDocument (UnrunnableT js t m) where

170instance Monad m => HasDocument (UnrunnableT js t m) where

170 askDocument = unrunnable

171 askDocument = unrunnable

171instance Monad m => HasJSContext (UnrunnableT js t m) where

172instance Monad m => HasJSContext (UnrunnableT js t m) where

@@ -204,12 +205,13 @@ instance Monad m => MonadReflexCreateTrigger t (UnrunnableT js t m) where

204 newFanEventWithTrigger _ = unrunnable

205 newFanEventWithTrigger _ = unrunnable

205instance Monad m => MonadFix (UnrunnableT js t m) where

206instance Monad m => MonadFix (UnrunnableT js t m) where

206 mfix _ = unrunnable

207 mfix _ = unrunnable

207−instance Monad m => MonadHold t (UnrunnableT js t m) where

208+instance (Monad m, MonadHold t m) => MonadHold t (UnrunnableT js t m) where

208 hold _ _ = unrunnable

209 hold _ _ = unrunnable

209 holdDyn _ _ = unrunnable

210 holdDyn _ _ = unrunnable

210 holdIncremental _ _ = unrunnable

211 holdIncremental _ _ = unrunnable

211 buildDynamic _ _ = unrunnable

212 buildDynamic _ _ = unrunnable

212 headE _ = unrunnable

213 headE _ = unrunnable

214+ now = unrunnable

213instance Monad m => MonadSample t (UnrunnableT js t m) where

215instance Monad m => MonadSample t (UnrunnableT js t m) where

214 sample _ = unrunnable

216 sample _ = unrunnable

215instance Monad m => MonadIO (UnrunnableT js t m) where

217instance Monad m => MonadIO (UnrunnableT js t m) where

@@ -227,7 +229,7 @@ instance (Reflex t, Monad m) => DomRenderHook t (UnrunnableT js t m) where

227 withRenderHook _ _ = unrunnable

229 withRenderHook _ _ = unrunnable

228 requestDomAction _ = unrunnable

230 requestDomAction _ = unrunnable

229 requestDomAction_ _ = unrunnable

231 requestDomAction_ _ = unrunnable

230−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

231 type Client (UnrunnableT js t m) = UnrunnableT js t m

233 type Client (UnrunnableT js t m) = UnrunnableT js t m

232 prerender _ _ = unrunnable

234 prerender _ _ = unrunnable

233

235

reflex-dom-core/src/Reflex/Dom/Test/Screenshot.hsdeleted−256

@@ -1,256 +0,0 @@

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−module Reflex.Dom.Test.Screenshot

13− ( TestWidget

14− , TestWidgetConfig (..)

15− , testWidget, testWidget', testWidgetStatic, testWidgetHydrated

16− , testWithSelenium

17− ) where

18−

19−import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)

20−import Control.Monad (when, void)

21−import Control.Monad.Catch (MonadMask, handle, finally)

22−import Control.Monad.Fix (MonadFix)

23−import Control.Monad.IO.Class (MonadIO, liftIO)

24−import Data.Text (Text)

25−import Language.Javascript.JSaddle

26−import Language.Javascript.JSaddle.Warp

27−import Network.HTTP.Types (status200)

28−import Network.Socket (PortNumber)

29−import Network.Wai (responseLBS)

30−import Network.WebSockets (defaultConnectionOptions)

31−import Reflex.Dom.Core

32−import System.IO (stderr)

33−import System.IO.Silently (hSilence)

34−import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)

35−import System.Which (staticWhich)

36−import qualified Data.Text as T

37−

38−import qualified Control.Concurrent.Async as Async

39−import qualified Data.Text.Encoding as TE

40−import qualified Data.ByteString.Lazy as LBS

41−import qualified Network.Wai.Handler.Warp as Warp

42−

43−import Test.Hspec.WebDriver (SpecWith, WdTestSession, hspec, sessionWith, using)

44−import Test.Util.ChromeFlags

45−import Test.Util.UnshareNetwork

46−import Test.WebDriver (WD)

47−import qualified Test.WebDriver as WD

48−import qualified Test.WebDriver.Capabilities as WD

49−

50−deriving instance MonadMask WD

51−

52−testWithSelenium

53− :: Bool

54− -- ^ True means that the browser is invoked in headless mode, False means that

55− -- the user can see the interaction happening on the browser (useful for debugging).

56− -> SpecWith (WdTestSession a)

57− -- ^ The tests we want to write in the selenium session

58− -> IO ()

59−testWithSelenium isHeadless actualTests = do

60− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother

61− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do

62− withSeleniumServer $ \selenium -> do

63− let browserPath = T.strip $ T.pack chromium

64− when (T.null browserPath) $ fail "No browser found"

65− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }

66− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

67− hspec (sessionWith wdConfig "" . using [(chromeCaps', "")] $ actualTests) `finally` _selenium_stopServer selenium

68−

69−seleniumPort, jsaddlePort :: PortNumber

70−seleniumPort = 8000

71−jsaddlePort = 8001

72−

73−data Selenium = Selenium

74− { _selenium_portNumber :: PortNumber

75− , _selenium_stopServer :: IO ()

76− }

77−

78−startSeleniumServer :: PortNumber -> IO (IO ())

79−startSeleniumServer port = do

80− (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])

81− { std_in = NoStream

82− , std_out = NoStream

83− , std_err = NoStream

84− }

85− return $ terminateProcess ph

86−

87−withSeleniumServer :: (Selenium -> IO ()) -> IO ()

88−withSeleniumServer f = do

89− stopServer <- startSeleniumServer seleniumPort

90− threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on

91− f $ Selenium

92− { _selenium_portNumber = seleniumPort

93− , _selenium_stopServer = stopServer

94− }

95−

96−chromium :: FilePath

97−chromium = $(staticWhich "chromium")

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−type TestWidget js t m =

110− (DomBuilder t m, MonadHold t m, PostBuild t m

111− , Prerender js t m, PerformEvent t m, TriggerEvent t m

112− , MonadFix m, MonadIO (Performable m), MonadIO m)

113−

114−data TestWidgetConfig = TestWidgetConfig

115− { testWidgetConfig_debug :: Bool

116− -- ^ If this flag is set to True, during the test we will emit debug messages

117− -- giving insight on our progress in the hydratation progress

118− , testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

119− -- ^ We can add widgets here that will be included in the head of the page

120− -- (useful for example to include external js libraries in the tests)

121− }

122−

123−testWidget

124− :: TestWidgetConfig

125− -> WD a

126− -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

127− -> WD b

128− -- ^ Webdriver commands to run after hydration switchover

129− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

130− -- ^ Widget we are testing (contents of body)

131− -> WD b

132−testWidget cfg before after widget = testWidget' cfg before (const after) widget

133−

134−testWidgetStatic

135− :: TestWidgetConfig

136− -> WD ()

137− -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

138− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

139− -- ^ Widget we are testing (contents of body)

140− -> WD ()

141−testWidgetStatic cfg before widget = testWidget' cfg (void before) (const $ pure ()) widget

142−

143−testWidgetHydrated

144− :: TestWidgetConfig

145− -> WD b

146− -- ^ Webdriver commands to run after hydration switchover

147− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

148− -- ^ Widget we are testing (contents of body)

149− -> WD b

150−testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget

151−

152−testWidget'

153− :: TestWidgetConfig

154− -> WD a

155− -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

156− -> (a -> WD b)

157− -- ^ Webdriver commands to run after hydration switchover

158− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

159− -- ^ Widget we are testing (contents of body)

160− -> WD b

161−testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover bodyWidget = do

162− let putStrLnDebug :: MonadIO m => Text -> m ()

163− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

164− staticApp = do

165− el "head" $ headWidget

166− el "body" $ do

167− bodyWidget

168− el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False

169− putStrLnDebug "rendering static"

170− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp

171− putStrLnDebug "rendered static"

172− waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run

173− waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover

174− let entryPoint = do

175− putStrLnDebug "taking waitBeforeJS"

176− liftIO $ takeMVar waitBeforeJS

177− let switchOverAction = do

178− putStrLnDebug "switchover syncPoint"

179− syncPoint

180− putStrLnDebug "putting waitUntilSwitchover"

181− liftIO $ putMVar waitUntilSwitchover ()

182− putStrLnDebug "put waitUntilSwitchover"

183− putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"

184− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget

185− putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"

186− syncPoint

187− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do

188− putStrLnDebug "sending response"

189− r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html

190− putStrLnDebug "sent response"

191− return r

192− waitJSaddle <- liftIO newEmptyMVar

193− let settings = foldr ($) Warp.defaultSettings

194− [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort

195− , Warp.setBeforeMainLoop $ do

196− putStrLnDebug "putting waitJSaddle"

197− putMVar waitJSaddle ()

198− putStrLnDebug "put waitJSaddle"

199− ]

200− -- hSilence to get rid of ConnectionClosed logs

201− silenceIfDebug = if withDebugging then id else hSilence [stderr]

202− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application

203− withAsync' jsaddleWarp $ do

204− putStrLnDebug "taking waitJSaddle"

205− liftIO $ takeMVar waitJSaddle

206− putStrLnDebug "opening page"

207− WD.openPage $ "http://localhost:" <> show jsaddlePort

208− putStrLnDebug "running beforeJS"

209− a <- beforeJS

210− putStrLnDebug "putting waitBeforeJS"

211− liftIO $ putMVar waitBeforeJS ()

212− putStrLnDebug "taking waitUntilSwitchover"

213− liftIO $ takeMVar waitUntilSwitchover

214− putStrLnDebug "running afterSwitchover"

215− afterSwitchover a

216−

217−--------------------------------------------------------------------------------

218−-- Utilities

219−--------------------------------------------------------------------------------

220−

221−withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b

222−withAsync' f g = bracket

223− (liftIO $ Async.async f)

224− (liftIO . Async.uninterruptibleCancel)

225− (const g)

226−

227−--------------------------------------------------------------------------------

228−

229−{- Note: a nicer interface?

230−

231−This would have lead to a niced interface, but I don't think this solution is

232−expressible with the library

233−

234−data SessionData = SessionData

235− { sessionData_wdConfig :: WD.WDConfig

236− , sessionData_capabilities :: [Capabilities]

237− , sessionData_selenium :: Selenium

238− }

239−

240−testSpec = around bracketSelenium $ do

241− describe "createRecipe" $ _what

242−

243−bracketSelenium :: (SessionData -> IO ()) -> IO ()

244−bracketSelenium action = do

245− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother

246− isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"

247− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do

248− withSeleniumServer $ \selenium -> do

249− let browserPath = T.strip $ T.pack chromium

250− when (T.null browserPath) $ fail "No browser found"

251− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"

252− let

253− wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }

254− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

255− action (SessionData wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium

256−-}

reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+1

@@ -70,6 +70,7 @@ import Reflex.Network

70import Reflex.PostBuild.Class

71import Reflex.Workflow

73+import Control.Arrow

73import Control.Lens hiding (children, element)

74import Control.Lens hiding (children, element)

74import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

75import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

75import Data.Align

76import Data.Align

reflex-dom-core/src/Reflex/Dom/Widget/Input.hs+4−3

@@ -30,8 +30,12 @@ import Data.Functor.Misc

30import Data.Map (Map)

31import qualified Data.Map as Map

32import Data.Maybe

33+import Data.Semigroup

33import Data.Text (Text)

34import Data.Text (Text)

34import qualified Data.Text as T

35import qualified Data.Text as T

36+import qualified GHCJS.DOM.GlobalEventHandlers as Events

37+import GHCJS.DOM.EventM (on)

38+import qualified GHCJS.DOM.FileList as FileList

35import GHCJS.DOM.HTMLInputElement (HTMLInputElement)

39import GHCJS.DOM.HTMLInputElement (HTMLInputElement)

36import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)

40import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)

37import GHCJS.DOM.Types (MonadJSM, File, uncheckedCastTo)

41import GHCJS.DOM.Types (MonadJSM, File, uncheckedCastTo)

@@ -625,9 +629,6 @@ instance HasAttributes (FileInputConfig t) where

625 type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)

629 type Attrs (FileInputConfig t) = Dynamic t (Map Text Text)

626 attributes = fileInputConfig_attributes

630 attributes = fileInputConfig_attributes

627

631

628−class HasSetValue a where

629− type SetValue a :: *

630− setValue :: Lens' a (SetValue a)

631

632

632instance HasSetValue (TextAreaConfig t) where

633instance HasSetValue (TextAreaConfig t) where

633 type SetValue (TextAreaConfig t) = Event t Text

634 type SetValue (TextAreaConfig t) = Event t Text

reflex-dom-core/src/Reflex/Dom/Widget/Lazy.hs+2−1

@@ -20,6 +20,7 @@ import Control.Monad.Fix

20import Data.Fixed

21import Data.Map (Map)

22import qualified Data.Map as Map

23+import Data.Monoid

23import Data.Text (Text)

24import Data.Text (Text)

24import qualified Data.Text as T

25import qualified Data.Text as T

25import GHCJS.DOM.Element

26import GHCJS.DOM.Element

@@ -116,7 +117,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu

116 "overflow" =: "hidden" <>

117 "overflow" =: "hidden" <>

117 "position" =: "relative"

118 "position" =: "relative"

118 mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>

119 mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>

119− "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>

120+ "top" =: (<> "px") (T.pack $ show $ keyToIndex k * rowPx) <>

120 "position" =: "absolute" <>

121 "position" =: "absolute" <>

121 "width" =: "100%"

122 "width" =: "100%"

122 findWindow sizeIncrement windowSize startingPosition =

123 findWindow sizeIncrement windowSize startingPosition =

reflex-dom-core/src/Reflex/Dom/Widget/Resize.hs+2

@@ -16,10 +16,12 @@ import Reflex.PerformEvent.Class

16import Reflex.PostBuild.Class

17import Reflex.TriggerEvent.Class

19+import Control.Monad

19import Control.Monad.Fix

20import Control.Monad.Fix

20import Control.Monad.IO.Class

21import Control.Monad.IO.Class

21import Data.Map (Map)

22import Data.Map (Map)

22import qualified Data.Map as Map

23import qualified Data.Map as Map

24+import Data.Monoid

23import Data.Text (Text)

25import Data.Text (Text)

24import qualified Data.Text as T

26import qualified Data.Text as T

25import GHCJS.DOM.Element

27import GHCJS.DOM.Element

reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+2−2

@@ -15,7 +15,7 @@ import Data.Text (Text)

15import Data.ByteString (ByteString)

16import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)

17import GHCJS.DOM.Enums

18−import GHCJS.DOM.EventM (EventM, on)

18+import GHCJS.DOM.EventM (EventM, on, onSync)

19import GHCJS.DOM.EventTarget (dispatchEvent)

20import GHCJS.DOM.Types (MonadJSM, ToJSString, FormData, Document, Blob (..), ArrayBuffer (..), JSVal, JSM, IsEvent, XMLHttpRequestProgressEvent, ProgressEvent, Event, XMLHttpRequestUpload, FromJSString, ArrayBufferView (..), liftJSM, castTo)

21import GHCJS.DOM.XMLHttpRequest

@@ -114,7 +114,7 @@ xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent

114xmlHttpRequestOntimeout = (`on` timeout)

115

116xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())

117−xmlHttpRequestOnreadystatechange = (`on` readyStateChange)

117+xmlHttpRequestOnreadystatechange = (`onSync` readyStateChange)

118

119xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m ()

120xmlHttpRequestSetTimeout = setTimeout

reflex-dom-core/test/gc.hs+1−1

@@ -47,7 +47,7 @@ failureLimit = 0

48main :: IO ()

49main = 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

51 withSandboxedChromeFlags True $ \chromeFlags -> do

52 mainThread <- myThreadId

53 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)

2import System.Exit (exitFailure, exitSuccess)

4main :: IO ()

reflex-dom-core/test/hydration.hs+353−40

@@ -20,6 +20,14 @@

21{-# OPTIONS_GHC -fno-warn-orphans #-}

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+

23import Prelude hiding (fail)

31import Prelude hiding (fail)

24import Control.Concurrent

32import Control.Concurrent

25import qualified Control.Concurrent.Async as Async

33import qualified Control.Concurrent.Async as Async

@@ -137,7 +145,7 @@ deriving instance MonadFail WD

137

145

138main :: IO ()

146main :: IO ()

139main = do

147main = do

140− unshareNetork

148+ unshareNetwork

141 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"

149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"

142 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do

150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do

143 withSeleniumServer $ \selenium -> do

151 withSeleniumServer $ \selenium -> do

@@ -146,13 +154,13 @@ main = do

146 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"

154 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"

147 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }

155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }

148 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

149− hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium

157+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium

150

158

151−tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec

159+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec

152tests withDebugging wdConfig caps _selenium = do

160tests withDebugging wdConfig caps _selenium = do

153 let putStrLnDebug :: MonadIO m => Text -> m ()

161 let putStrLnDebug :: MonadIO m => Text -> m ()

154 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

155− session' = sessionWith wdConfig "" . using (map (,"") caps)

163+ session' t = sessionWith wdConfig t . using caps

156 runWD m = runWDOptions (WdOptions False) $ do

164 runWD m = runWDOptions (WdOptions False) $ do

157 putStrLnDebug "before"

165 putStrLnDebug "before"

158 r <- m

166 r <- m

@@ -161,10 +169,10 @@ tests withDebugging wdConfig caps _selenium = do

161 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b

169 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b

162 testWidgetStatic = testWidgetStaticDebug withDebugging

170 testWidgetStatic = testWidgetStaticDebug withDebugging

163 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b

171 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b

164− testWidget = testWidgetDebug withDebugging

172+ testWidget = testWidgetDebug True withDebugging

165 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b

173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b

166− testWidget' = testWidgetDebug' withDebugging

174+ testWidget' = testWidgetDebug' True withDebugging

167− describe "text" $ session' $ do

175+ session' "text" $ do

168 it "works" $ runWD $ do

176 it "works" $ runWD $ do

169 testWidgetStatic (checkBodyText "hello world") $ do

177 testWidgetStatic (checkBodyText "hello world") $ do

170 text "hello world"

178 text "hello world"

@@ -225,7 +233,7 @@ tests withDebugging wdConfig caps _selenium = do

225 click <- button ""

233 click <- button ""

226 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click

234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click

227

235

228− describe "element" $ session' $ do

236+ session' "element" $ do

229 it "works with domEvent Click" $ runWD $ do

237 it "works with domEvent Click" $ runWD $ do

230 clickedRef <- liftIO $ newRef False

238 clickedRef <- liftIO $ newRef False

231 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do

239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do

@@ -289,21 +297,78 @@ tests withDebugging wdConfig caps _selenium = do

289 let click = domEvent Click e

297 let click = domEvent Click e

290 return ()

298 return ()

291

299

292− describe "inputElement" $ 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 ()

293− describe "hydration" $ session' $ do

358+ describe "hydration" $ do

294 it "doesn't wipe user input when switching over" $ runWD $ do

359 it "doesn't wipe user input when switching over" $ runWD $ do

295− inputRef <- newRef ("" :: Text)

360+ inputRef <- newRef ("hello " :: Text)

296 testWidget'

361 testWidget'

297 (do

362 (do

298 e <- findElemWithRetry $ WD.ByTag "input"

363 e <- findElemWithRetry $ WD.ByTag "input"

299− WD.sendKeys "hello world" e

364+ WD.sendKeys "world" e

300 pure e)

365 pure e)

301 (\e -> do

366 (\e -> do

302 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"

367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"

303 WD.click =<< findElemWithRetry (WD.ByTag "button")

368 WD.click =<< findElemWithRetry (WD.ByTag "button")

304 readRef inputRef `shouldBeWithRetryM` "hello world"

369 readRef inputRef `shouldBeWithRetryM` "hello world"

305 ) $ do

370 ) $ do

306− e <- inputElement def

371+ e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "

307 click <- button "save"

372 click <- button "save"

308 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click

373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click

309 it "captures user input after switchover" $ runWD $ do

374 it "captures user input after switchover" $ runWD $ do

@@ -360,24 +425,49 @@ tests withDebugging wdConfig caps _selenium = do

360 checkedByUIRef <- newRef False

425 checkedByUIRef <- newRef False

361 checkedRef <- newRef False

426 checkedRef <- newRef False

362 setCheckedChan <- liftIO newChan

427 setCheckedChan <- liftIO newChan

428+ let checkStatic = do

429+ e <- findElemWithRetry $ WD.ByTag "input"

430+ WD.attr e "checked" `shouldBeWithRetryM` Nothing

431+ pure e

363− let checkValue = do

432+ checkValue e = do

364 readRef checkedByUIRef `shouldBeWithRetryM` False

433 readRef checkedByUIRef `shouldBeWithRetryM` False

365 readRef checkedRef `shouldBeWithRetryM` False

434 readRef checkedRef `shouldBeWithRetryM` False

366− e <- findElemWithRetry $ WD.ByTag "input"

435+ WD.attr e "checked" `shouldBeWithRetryM` Nothing

367 WD.moveToCenter e

436 WD.moveToCenter e

368 WD.click e

437 WD.click e

369 readRef checkedByUIRef `shouldBeWithRetryM` True

438 readRef checkedByUIRef `shouldBeWithRetryM` True

370 readRef checkedRef `shouldBeWithRetryM` True

439 readRef checkedRef `shouldBeWithRetryM` True

440+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"

371 liftIO $ writeChan setCheckedChan False

441 liftIO $ writeChan setCheckedChan False

372 readRef checkedByUIRef `shouldBeWithRetryM` True

442 readRef checkedByUIRef `shouldBeWithRetryM` True

373 readRef checkedRef `shouldBeWithRetryM` False

443 readRef checkedRef `shouldBeWithRetryM` False

444+ WD.attr e "checked" `shouldBeWithRetryM` Nothing

374− testWidget (pure ()) checkValue $ do

445+ testWidget' checkStatic checkValue $ do

375 setChecked <- triggerEventWithChan setCheckedChan

446 setChecked <- triggerEventWithChan setCheckedChan

376 e <- inputElement $ def

447 e <- inputElement $ def

377 & initialAttributes .~ "type" =: "checkbox"

448 & initialAttributes .~ "type" =: "checkbox"

378 & inputElementConfig_setChecked .~ setChecked

449 & inputElementConfig_setChecked .~ setChecked

379 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e

450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e

380 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)

451 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)

381 it "captures file uploads" $ runWD $ do

471 it "captures file uploads" $ runWD $ do

382 filesRef :: IORef [Text] <- newRef []

472 filesRef :: IORef [Text] <- newRef []

383 let uploadFile = do

473 let uploadFile = do

@@ -393,8 +483,117 @@ tests withDebugging wdConfig caps _selenium = do

393 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do

483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do

394 names <- liftJSM $ traverse File.getName fs

484 names <- liftJSM $ traverse File.getName fs

395 liftIO $ writeRef filesRef names

485 liftIO $ writeRef filesRef names

396−

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

397− describe "hydration/immediate" $ session' $ do

596+ describe "hydration/immediate" $ do

398 it "captures user input after switchover" $ runWD $ do

597 it "captures user input after switchover" $ runWD $ do

399 inputRef :: IORef Text <- newRef ""

598 inputRef :: IORef Text <- newRef ""

400 let checkValue = do

599 let checkValue = do

@@ -474,8 +673,31 @@ tests withDebugging wdConfig caps _selenium = do

474 names <- liftJSM $ traverse File.getName fs

673 names <- liftJSM $ traverse File.getName fs

475 liftIO $ writeRef filesRef names

674 liftIO $ writeRef filesRef names

476

675

477− describe "textAreaElement" $ do

676+ session' "textAreaElement" $ do

478− describe "hydration" $ session' $ 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

479 it "doesn't wipe user input when switching over" $ runWD $ do

701 it "doesn't wipe user input when switching over" $ runWD $ do

480 inputRef <- newRef ("" :: Text)

702 inputRef <- newRef ("" :: Text)

481 testWidget'

703 testWidget'

@@ -541,8 +763,90 @@ tests withDebugging wdConfig caps _selenium = do

541 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }

763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }

542 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e

764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e

543 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)

765 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

544

848

545− describe "hydration/immediate" $ session' $ do

849+ describe "hydration/immediate" $ do

546 it "captures user input after switchover" $ runWD $ do

850 it "captures user input after switchover" $ runWD $ do

547 inputRef :: IORef Text <- newRef ""

851 inputRef :: IORef Text <- newRef ""

548 let checkValue = do

852 let checkValue = do

@@ -584,13 +888,13 @@ tests withDebugging wdConfig caps _selenium = do

584 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e

888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e

585 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)

889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)

586

890

587− describe "selectElement" $ do

891+ session' "selectElement" $ do

588 let options :: DomBuilder t m => m ()

892 let options :: DomBuilder t m => m ()

589 options = do

893 options = do

590 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"

894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"

591 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"

895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"

592 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"

896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"

593− describe "hydration" $ session' $ do

897+ describe "hydration" $ do

594 it "sets initial value correctly" $ runWD $ do

898 it "sets initial value correctly" $ runWD $ do

595 inputRef <- newRef ("" :: Text)

899 inputRef <- newRef ("" :: Text)

596 let setup = do

900 let setup = do

@@ -664,7 +968,7 @@ tests withDebugging wdConfig caps _selenium = do

664 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e

968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e

665 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)

969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)

666

970

667− describe "hydration/immediate" $ session' $ do

971+ describe "hydration/immediate" $ do

668 it "captures user input after switchover" $ runWD $ do

972 it "captures user input after switchover" $ runWD $ do

669 inputRef :: IORef Text <- newRef ""

973 inputRef :: IORef Text <- newRef ""

670 let checkValue = do

974 let checkValue = do

@@ -710,7 +1014,7 @@ tests withDebugging wdConfig caps _selenium = do

710 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e

1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e

711 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)

1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)

712

1016

713− describe "prerender" $ session' $ do

1017+ session' "prerender" $ do

714 it "works in simple case" $ runWD $ do

1018 it "works in simple case" $ runWD $ do

715 testWidget (checkBodyText "One") (checkBodyText "Two") $ do

1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do

716 prerender_ (text "One") (text "Two")

1020 prerender_ (text "One") (text "Two")

@@ -779,7 +1083,7 @@ tests withDebugging wdConfig caps _selenium = do

779 prerender_ (pure ()) (liftIO $ trigger "Client")

1083 prerender_ (pure ()) (liftIO $ trigger "Client")

780 textNode $ TextNodeConfig "Initial" $ Just e

1084 textNode $ TextNodeConfig "Initial" $ Just e

781

1085

782− describe "namespaces" $ session' $ do

1086+ session' "namespaces" $ do

783 it "dyn can be nested in namespaced widget" $ runWD $ do

1087 it "dyn can be nested in namespaced widget" $ runWD $ do

784 testWidget (pure ()) (checkTextInTag "svg" "one") $ do

1088 testWidget (pure ()) (checkTextInTag "svg" "one") $ do

785 let svgRootCfg = def

1089 let svgRootCfg = def

@@ -788,7 +1092,7 @@ tests withDebugging wdConfig caps _selenium = do

788 void $ element "svg" svgRootCfg $ do

1092 void $ element "svg" svgRootCfg $ do

789 dyn_ $ text "one" <$ pure ()

1093 dyn_ $ text "one" <$ pure ()

790

1094

791− describe "runWithReplace" $ session' $ do

1095+ session' "runWithReplace" $ do

792 it "works" $ runWD $ do

1096 it "works" $ runWD $ do

793 replaceChan :: Chan Text <- liftIO newChan

1097 replaceChan :: Chan Text <- liftIO newChan

794 let setup = findElemWithRetry $ WD.ByTag "div"

1098 let setup = findElemWithRetry $ WD.ByTag "div"

@@ -962,7 +1266,9 @@ tests withDebugging wdConfig caps _selenium = do

962 _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace

1266 _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace

963 text "|after"

1267 text "|after"

964 void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test

1268 void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test

1269+ -- TODO This test actually causes a hydration failure, but it wasn't

1270+ -- previously detected, so I've marked it pending

965− it "ignores missing ending bracketing comments" $ runWD $ do

1271+ xit "ignores missing ending bracketing comments" $ runWD $ do

966 replaceChan :: Chan () <- liftIO newChan

1272 replaceChan :: Chan () <- liftIO newChan

967 let

1273 let

968 preSwitchover = do

1274 preSwitchover = do

@@ -984,7 +1290,7 @@ tests withDebugging wdConfig caps _selenium = do

984 _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace

1290 _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace

985 text "|after"

1291 text "|after"

986

1292

987− describe "traverseDMapWithKeyWithAdjust" $ session' $ do

1293+ session' "traverseDMapWithKeyWithAdjust" $ do

988 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)

1294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)

989 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do

1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do

990 elClass "span" "key" $ text $ textKey k

1296 elClass "span" "key" $ text $ textKey k

@@ -1087,7 +1393,7 @@ tests withDebugging wdConfig caps _selenium = do

1087 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]

1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]

1088 liftIO $ dmap `H.shouldBe` keyMap

1394 liftIO $ dmap `H.shouldBe` keyMap

1089

1395

1090− describe "traverseIntMapWithKeyWithAdjust" $ session' $ do

1396+ session' "traverseIntMapWithKeyWithAdjust" $ do

1091 let textKeyInt k = "key" <> T.pack (show k)

1397 let textKeyInt k = "key" <> T.pack (show k)

1092 intMap = IntMap.fromList

1398 intMap = IntMap.fromList

1093 [ (1, "one")

1399 [ (1, "one")

@@ -1194,7 +1500,7 @@ tests withDebugging wdConfig caps _selenium = do

1194 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]

1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]

1195 liftIO $ dmap `H.shouldBe` intMap

1501 liftIO $ dmap `H.shouldBe` intMap

1196

1502

1197− describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do

1503+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do

1198 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)

1504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)

1199 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do

1505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do

1200 elClass "span" "key" $ text $ textKey2 k

1506 elClass "span" "key" $ text $ textKey2 k

@@ -1274,8 +1580,8 @@ tests withDebugging wdConfig caps _selenium = do

1274 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan

1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan

1275 liftIO $ assertEqual "DMap" initMap dmap

1581 liftIO $ assertEqual "DMap" initMap dmap

1276

1582

1277− describe "hydrating invalid HTML" $ session' $ do

1583+ session' "hydrating invalid HTML" $ do

1278− it "can hydrate list in paragraph" $ runWD $ do

1584+ xit "can hydrate list in paragraph" $ runWD $ do

1279 let preSwitchover = do

1585 let preSwitchover = do

1280 checkBodyText "before\ninner\nafter"

1586 checkBodyText "before\ninner\nafter"

1281 -- Two tags should be present

1587 -- Two tags should be present

@@ -1292,7 +1598,8 @@ tests withDebugging wdConfig caps _selenium = do

1292 shouldContainText "before\ninner\nafter" p1

1598 shouldContainText "before\ninner\nafter" p1

1293 elementShouldBeRemoved ol

1599 elementShouldBeRemoved ol

1294 elementShouldBeRemoved p2

1600 elementShouldBeRemoved p2

1601+ -- Don't fail fatally when hydration encounters the invalid DOM

1295− testWidget' preSwitchover check $ do

1602+ testWidgetDebug' False withDebugging preSwitchover check $ do

1296 -- This is deliberately invalid HTML, the browser will interpret it as

1603 -- This is deliberately invalid HTML, the browser will interpret it as

1297 -- before<ol>inner</ol>after

1604 -- before<ol>inner</ol>after

1298 el "p" $ do

1605 el "p" $ do

@@ -1303,7 +1610,7 @@ tests withDebugging wdConfig caps _selenium = do

1303 -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.

1610 -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.

1304 -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.

1611 -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.

1305 -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.

1612 -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.

1306− describe "dropdown" $ session' $ do

1613+ session' "dropdown" $ do

1307 let doTest expectedOpts (initialValue :: Text) = do

1614 let doTest expectedOpts (initialValue :: Text) = do

1308 let doCheck = do

1615 let doCheck = do

1309 es <- findElemsWithRetry $ WD.ByTag "option"

1616 es <- findElemsWithRetry $ WD.ByTag "option"

@@ -1418,11 +1725,12 @@ testWidgetStaticDebug

1418 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

1419 -- ^ Widget we are testing

1726 -- ^ Widget we are testing

1420 -> WD b

1727 -> WD b

1421−testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w

1728+testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w

1422

1729

1423-- | TODO: do something about JSExceptions not causing tests to fail

1730-- | TODO: do something about JSExceptions not causing tests to fail

1424testWidgetDebug

1731testWidgetDebug

1425 :: Bool

1732 :: Bool

1733+ -> Bool

1426 -> WD ()

1734 -> WD ()

1427 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

1735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

1428 -> WD b

1736 -> WD b

@@ -1430,12 +1738,16 @@ testWidgetDebug

1430 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

1431 -- ^ Widget we are testing

1739 -- ^ Widget we are testing

1432 -> WD b

1740 -> WD b

1433−testWidgetDebug withDebugging beforeJS afterSwitchover =

1741+testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =

1434− testWidgetDebug' withDebugging beforeJS (const afterSwitchover)

1742+ testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)

1743+

1744+data HydrationFailedException = HydrationFailedException deriving Show

1745+instance Exception HydrationFailedException

1435

1746

1436-- | TODO: do something about JSExceptions not causing tests to fail

1747-- | TODO: do something about JSExceptions not causing tests to fail

1437testWidgetDebug'

1748testWidgetDebug'

1438 :: Bool

1749 :: Bool

1750+ -> Bool

1439 -> WD a

1751 -> WD a

1440 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

1752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

1441 -> (a -> WD b)

1753 -> (a -> WD b)

@@ -1443,7 +1755,7 @@ testWidgetDebug'

1443 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

1444 -- ^ Widget we are testing (contents of body)

1756 -- ^ Widget we are testing (contents of body)

1445 -> WD b

1757 -> WD b

1446−testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do

1758+testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do

1447 let putStrLnDebug :: MonadIO m => Text -> m ()

1759 let putStrLnDebug :: MonadIO m => Text -> m ()

1448 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

1760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

1449 staticApp = do

1761 staticApp = do

@@ -1455,6 +1767,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do

1455 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp

1767 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp

1456 putStrLnDebug "rendered static"

1768 putStrLnDebug "rendered static"

1457 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run

1769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run

1770+ onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()

1458 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover

1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover

1459 let entryPoint = do

1772 let entryPoint = do

1460 putStrLnDebug "taking waitBeforeJS"

1773 putStrLnDebug "taking waitBeforeJS"

@@ -1466,7 +1779,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do

1466 liftIO $ putMVar waitUntilSwitchover ()

1779 liftIO $ putMVar waitUntilSwitchover ()

1467 putStrLnDebug "put waitUntilSwitchover"

1780 putStrLnDebug "put waitUntilSwitchover"

1468 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"

1781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"

1469− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget

1782+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget

1470 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"

1783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"

1471 syncPoint

1784 syncPoint

1472 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do

1785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do

reflex-dom-test-selenium/LICENSEnew file+12

@@ -0,0 +1,12 @@

4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

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+

reflex-dom-test-selenium/Main.hsdeleted−4

@@ -1,4 +0,0 @@

1−module Main where

2−

3−main :: IO ()

4−main = putStrLn "Hello, Haskell!"

reflex-dom-test-selenium/add-overrides.nixnew file+20

@@ -0,0 +1,20 @@

1+{ nixpkgs }: testPackage:

2+ nixpkgs.haskell.lib.overrideCabal testPackage

3+ (drv: {

5+ # The headless browser run as part of the tests will exit without this

6+ preBuild = ''

7+ export HOME="$PWD"

8+ '';

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.cabal+19−38

@@ -14,44 +14,25 @@ Build-type: Simple

14library

15 hs-source-dirs: src

16 build-depends:

17− -- aeson >= 0.8 && < 1.5,

17+ async,

18− -- base >= 4.7 && < 4.14,

18+ base >= 4.7 && < 4.15,

19− -- bifunctors >= 4.2 && < 6,

20− -- bimap >= 0.3 && < 0.4,

21− -- blaze-builder >= 0.4.1 && < 0.5,

22− -- bytestring == 0.10.*,

19+ bytestring == 0.10.*,

23− -- case-insensitive < 1.3,

24− -- containers >= 0.6 && < 0.7,

25− -- constraints >= 0.9 && < 0.12,

26− -- contravariant >= 1.4 && < 1.6,

27− -- data-default >= 0.5 && < 0.8,

28− -- dependent-map >= 0.3 && < 0.4,

29− -- dependent-sum >= 0.6 && < 0.7,

30− -- dependent-sum-template >= 0.1 && < 0.2,

31− -- directory >= 1.2 && < 1.4,

32− -- exception-transformers == 0.4.*,

33− -- ghcjs-dom >= 0.9.1.0 && < 0.10,

34− -- jsaddle >= 0.9.0.0 && < 0.10,

35− -- process,

36− -- chrome-test-utils,

20+ chrome-test-utils,

37− -- async,

21+ exceptions,

38− -- jsaddle-warp,

22+ hspec-core,

39− -- -- keycode-0.2 has a bug on firefox

23+ hspec-webdriver >= 1.2.1,

40− -- keycode >= 0.2.1 && < 0.3,

24+ http-types,

41− -- lens >= 4.7 && < 5,

25+ jsaddle >= 0.9.0.0 && < 0.10,

42− -- monad-control >= 1.0.1 && < 1.1,

26+ jsaddle-warp,

43− -- mtl >= 2.1 && < 2.3,

27+ network,

44− -- primitive >= 0.5 && < 0.8,

28+ process,

45− -- random >= 1.1 && < 1.2,

46− -- ref-tf == 0.4.*,

47− -- reflex >= 0.6.2 && < 0.8,

29+ reflex-dom-core,

48− -- semigroups >= 0.16 && < 0.20,

30+ silently,

49− -- stm >= 2.4 && < 2.6,

50− -- text == 1.2.*,

31+ text == 1.2.*,

51− -- transformers >= 0.3 && < 0.6,

32+ wai,

52− -- network-uri >= 2.6.1 && < 2.7,

33+ warp,

53− -- webdriver,

34+ webdriver,

54− -- zenc == 0.1.*

35+ websockets

56 exposed-modules:

37 exposed-modules:

57 Reflex.Dom.Test.Selenium

38 Reflex.Dom.Test.Selenium

reflex-dom-test-selenium/src/Reflex/Dom/Test/Selenium.hs+76−83

@@ -9,16 +9,24 @@

10{-# OPTIONS_GHC -fno-warn-orphans #-}

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.

12−module Reflex.Dom.Test.Screenshot

17+module Reflex.Dom.Test.Selenium

13 ( TestWidget

18 ( TestWidget

14 , TestWidgetConfig (..)

19 , TestWidgetConfig (..)

15 , testWidget, testWidget', testWidgetStatic, testWidgetHydrated

20 , testWidget, testWidget', testWidgetStatic, testWidgetHydrated

16− , testWithSelenium

21+ , withSeleniumSpec

22+ , embedSpec

23+ , SeleniumSetupConfig (..)

17 ) where

24 ) where

19import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)

26import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)

20−import Control.Monad (when, void)

27+import Control.Exception (throwIO)

28+import Control.Monad (when)

21−import Control.Monad.Catch (MonadMask, handle, finally)

29+import Control.Monad.Catch (MonadMask, handle)

22import Control.Monad.Fix (MonadFix)

30import Control.Monad.Fix (MonadFix)

23import Control.Monad.IO.Class (MonadIO, liftIO)

31import Control.Monad.IO.Class (MonadIO, liftIO)

24import Data.Text (Text)

32import Data.Text (Text)

@@ -32,48 +40,47 @@ import Reflex.Dom.Core

32import System.IO (stderr)

40import System.IO (stderr)

33import System.IO.Silently (hSilence)

41import System.IO.Silently (hSilence)

34import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)

42import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)

35−import System.Which (staticWhich)

43+import Test.Hspec.WebDriver (Spec, SpecWith, WdTestSession, sessionWith, using)

36−import qualified Data.Text as T

44+import Test.Util.ChromeFlags

45+import Test.Util.UnshareNetwork

46+import Test.WebDriver (WD)

38import qualified Control.Concurrent.Async as Async

48import qualified Control.Concurrent.Async as Async

39−import qualified Data.Text.Encoding as TE

40import qualified Data.ByteString.Lazy as LBS

49import qualified Data.ByteString.Lazy as LBS

50+import qualified Data.Text as T

51+import qualified Data.Text.Encoding as TE

41import qualified Network.Wai.Handler.Warp as Warp

52import qualified Network.Wai.Handler.Warp as Warp

42−

53+import qualified Test.Hspec.Core.Spec as Hspec

43−import Test.Hspec.WebDriver (SpecWith, WdTestSession, hspec, sessionWith, using)

44−import Test.Util.ChromeFlags

45−import Test.Util.UnshareNetwork

46−import Test.WebDriver (WD)

47import qualified Test.WebDriver as WD

54import qualified Test.WebDriver as WD

48import qualified Test.WebDriver.Capabilities as WD

55import qualified Test.WebDriver.Capabilities as WD

50deriving instance MonadMask WD

57deriving instance MonadMask WD

52−testWithSelenium

59+data SeleniumSetupConfig = SeleniumSetupConfig

53− :: Bool

60+ { _seleniumSetupConfig_chromiumPath :: FilePath

61+ -- ^ Path to the chromium executable

62+ , _seleniumSetupConfig_headless :: Bool

54 -- ^ True means that the browser is invoked in headless mode, False means that

63 -- ^ True means that the browser is invoked in headless mode, False means that

55 -- the user can see the interaction happening on the browser (useful for debugging).

64 -- the user can see the interaction happening on the browser (useful for debugging).

56− -> SpecWith (WdTestSession a)

65+ , _seleniumSetupConfig_seleniumPort :: PortNumber

57− -- ^ The tests we want to write in the selenium session

66+ -- ^ The port number used by selenium

58− -> IO ()

67+ }

59−testWithSelenium isHeadless actualTests = do

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

60− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother

76+ liftIO $ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother

61− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do

77+ withSandboxedChromeFlags (_seleniumSetupConfig_headless config) $ \chromeFlags -> do

62− withSeleniumServer $ \selenium -> do

78+ withSeleniumServer (_seleniumSetupConfig_seleniumPort config) $ do

63− let browserPath = T.strip $ T.pack chromium

79+ let browserPath = T.strip $ T.pack $ _seleniumSetupConfig_chromiumPath config

64 when (T.null browserPath) $ fail "No browser found"

80 when (T.null browserPath) $ fail "No browser found"

65− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }

81+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _seleniumSetupConfig_seleniumPort config }

66 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

82 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

67− hspec (sessionWith wdConfig "" . using [(chromeCaps', "")] $ actualTests) `finally` _selenium_stopServer selenium

83+ runSpec $ sessionWith wdConfig "" . using [(chromeCaps', "chrome")]

68−

69−seleniumPort, jsaddlePort :: PortNumber

70−seleniumPort = 8000

71−jsaddlePort = 8001

72−

73−data Selenium = Selenium

74− { _selenium_portNumber :: PortNumber

75− , _selenium_stopServer :: IO ()

76− }

78startSeleniumServer :: PortNumber -> IO (IO ())

85startSeleniumServer :: PortNumber -> IO (IO ())

79startSeleniumServer port = do

86startSeleniumServer port = do

@@ -84,17 +91,10 @@ startSeleniumServer port = do

84 }

91 }

85 return $ terminateProcess ph

92 return $ terminateProcess ph

87−withSeleniumServer :: (Selenium -> IO ()) -> IO ()

94+withSeleniumServer :: PortNumber -> IO a -> IO a

88−withSeleniumServer f = do

95+withSeleniumServer port f = bracket (startSeleniumServer port) id $ \_ -> do

89− stopServer <- startSeleniumServer seleniumPort

90 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on

96 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on

91− f $ Selenium

97+ f

92− { _selenium_portNumber = seleniumPort

93− , _selenium_stopServer = stopServer

94− }

95−

96−chromium :: FilePath

97−chromium = $(staticWhich "chromium")

99chromeConfig :: Text -> [Text] -> WD.WDConfig

100chromeConfig fp flags =

@@ -106,20 +106,25 @@ chromeConfig fp flags =

106-- Function to test widgets

107--------------------------------------------------------------------------------

108

109+-- | The environment in which your widgets can be tested

109type TestWidget js t m =

110type TestWidget js t m =

110 (DomBuilder t m, MonadHold t m, PostBuild t m

111 (DomBuilder t m, MonadHold t m, PostBuild t m

111 , Prerender js t m, PerformEvent t m, TriggerEvent t m

112 , Prerender js t m, PerformEvent t m, TriggerEvent t m

112 , MonadFix m, MonadIO (Performable m), MonadIO m)

113 , MonadFix m, MonadIO (Performable m), MonadIO m)

113

114

115+-- | Configuration of individual tests

114data TestWidgetConfig = TestWidgetConfig

116data TestWidgetConfig = TestWidgetConfig

115− { testWidgetConfig_debug :: Bool

117+ { _testWidgetConfig_debug :: Bool

116 -- ^ If this flag is set to True, during the test we will emit debug messages

118 -- ^ If this flag is set to True, during the test we will emit debug messages

117− -- giving insight on our progress in the hydratation progress

118− , testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

119+ , _testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

119 -- ^ We can add widgets here that will be included in the head of the page

120 -- ^ We can add widgets here that will be included in the head of the page

120 -- (useful for example to include external js libraries in the tests)

121 -- (useful for example to include external js libraries in the tests)

122+ , _testWidgetConfig_jsaddlePort :: PortNumber

123+ -- ^ Port used by the jsaddle server

121 }

124 }

122

125

126+-- | Test a widget by running some webdriver commands before and after

127+-- hydration.

123testWidget

128testWidget

124 :: TestWidgetConfig

129 :: TestWidgetConfig

125 -> WD a

130 -> WD a

@@ -131,15 +136,18 @@ testWidget

131 -> WD b

136 -> WD b

132testWidget cfg before after widget = testWidget' cfg before (const after) widget

137testWidget cfg before after widget = testWidget' cfg before (const after) widget

133

138

139+-- | Test a widget by running some webdriver commands before hydration (on the

140+-- statically rendered page).

134testWidgetStatic

141testWidgetStatic

135 :: TestWidgetConfig

142 :: TestWidgetConfig

136− -> WD ()

143+ -> WD a

137 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

144 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

138 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

145 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

139 -- ^ Widget we are testing (contents of body)

146 -- ^ Widget we are testing (contents of body)

140− -> WD ()

147+ -> WD a

141−testWidgetStatic cfg before widget = testWidget' cfg (void before) (const $ pure ()) widget

148+testWidgetStatic cfg before widget = testWidget' cfg before pure widget

142

149

150+-- | Test a widget by running some webdriver commands after hydration.

143testWidgetHydrated

151testWidgetHydrated

144 :: TestWidgetConfig

152 :: TestWidgetConfig

145 -> WD b

153 -> WD b

@@ -149,6 +157,9 @@ testWidgetHydrated

149 -> WD b

157 -> WD b

150testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget

158testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget

151

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.

152testWidget'

163testWidget'

153 :: TestWidgetConfig

164 :: TestWidgetConfig

154 -> WD a

165 -> WD a

@@ -158,7 +169,7 @@ testWidget'

158 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

169 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

159 -- ^ Widget we are testing (contents of body)

170 -- ^ Widget we are testing (contents of body)

160 -> WD b

171 -> WD b

161−testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover bodyWidget = do

172+testWidget' (TestWidgetConfig withDebugging headWidget jsaddlePort) beforeJS afterSwitchover bodyWidget = do

162 let putStrLnDebug :: MonadIO m => Text -> m ()

173 let putStrLnDebug :: MonadIO m => Text -> m ()

163 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

174 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m

164 staticApp = do

175 staticApp = do

@@ -198,8 +209,8 @@ testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover

198 putStrLnDebug "put waitJSaddle"

209 putStrLnDebug "put waitJSaddle"

199 ]

210 ]

200 -- hSilence to get rid of ConnectionClosed logs

211 -- hSilence to get rid of ConnectionClosed logs

201− silenceIfDebug = if withDebugging then id else hSilence [stderr]

212+ silenceIfNotDebugging = if withDebugging then id else hSilence [stderr]

202− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application

213+ jsaddleWarp = silenceIfNotDebugging $ Warp.runSettings settings application

203 withAsync' jsaddleWarp $ do

214 withAsync' jsaddleWarp $ do

204 putStrLnDebug "taking waitJSaddle"

215 putStrLnDebug "taking waitJSaddle"

205 liftIO $ takeMVar waitJSaddle

216 liftIO $ takeMVar waitJSaddle

@@ -218,39 +229,21 @@ testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover

218-- Utilities

229-- Utilities

219--------------------------------------------------------------------------------

230--------------------------------------------------------------------------------

220

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+

221withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b

245withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b

222withAsync' f g = bracket

246withAsync' f g = bracket

223 (liftIO $ Async.async f)

247 (liftIO $ Async.async f)

224 (liftIO . Async.uninterruptibleCancel)

248 (liftIO . Async.uninterruptibleCancel)

225 (const g)

249 (const g)

226−

227−--------------------------------------------------------------------------------

228−

229−{- Note: a nicer interface?

230−

231−This would have lead to a niced interface, but I don't think this solution is

232−expressible with the library

233−

234−data SessionData = SessionData

235− { sessionData_wdConfig :: WD.WDConfig

236− , sessionData_capabilities :: [Capabilities]

237− , sessionData_selenium :: Selenium

238− }

239−

240−testSpec = around bracketSelenium $ do

241− describe "createRecipe" $ _what

242−

243−bracketSelenium :: (SessionData -> IO ()) -> IO ()

244−bracketSelenium action = do

245− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother

246− isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"

247− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do

248− withSeleniumServer $ \selenium -> do

249− let browserPath = T.strip $ T.pack chromium

250− when (T.null browserPath) $ fail "No browser found"

251− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"

252− let

253− wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }

254− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags

255− action (SessionData wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium

256−-}

reflex-dom/ChangeLog.md+8

@@ -1,5 +1,13 @@

1# Revision history for reflex-dom

3+## 0.6.1.0-r1

5+* Loosen reflex-dom-core version bounds

7+## 0.6.1.0

9+* Update for new dependent-map and dependent-sum (after the "some" package split)

10+

3## 0.6.0.0

11## 0.6.0.0

5* ([#379](https://github.com/reflex-frp/reflex-dom/pull/379)) Re-export all modules from `reflex-dom-core`. The newly re-exported modules are:

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:

reflex-dom/LICENSE+1−1

@@ -1,4 +1,4 @@

4Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

reflex-dom/reflex-dom.cabal+9−5

@@ -1,8 +1,12 @@

1cabal-version: 1.24

2Name: reflex-dom

3−Version: 0.6.0.0

3+Version: 0.6.1.0

4Synopsis: Functional Reactive Web Apps with Reflex

5Description:

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+ .

6 Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.

10 Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.

7 .

11 .

8 The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the

12 The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the

@@ -57,7 +61,7 @@ library

57 hs-source-dirs: src-android

61 hs-source-dirs: src-android

58 other-modules: Reflex.Dom.Android.MainWidget

62 other-modules: Reflex.Dom.Android.MainWidget

59 build-depends:

63 build-depends:

60− aeson >= 1.4 && < 1.5,

64+ aeson >= 1.4 && < 1.6,

61 android-activity == 0.1.*,

65 android-activity == 0.1.*,

62 data-default == 0.7.*,

66 data-default == 0.7.*,

63 jsaddle >= 0.9.6 && < 0.10

67 jsaddle >= 0.9.6 && < 0.10

@@ -67,10 +71,10 @@ library

67 cpp-options: -DANDROID

71 cpp-options: -DANDROID

68 build-tools: hsc2hs

72 build-tools: hsc2hs

69 build-depends:

73 build-depends:

70− base >= 4.7 && < 4.14,

74+ base >= 4.7 && < 4.15,

71 bytestring == 0.10.*,

75 bytestring == 0.10.*,

72− reflex >= 0.6.2 && < 0.8,

76+ reflex >= 0.8 && < 0.9,

73− reflex-dom-core == 0.6.0.0,

77+ reflex-dom-core >= 0.6.1.0 && <0.7,

74 text == 1.2.*

78 text == 1.2.*

75 if !impl(ghcjs)

79 if !impl(ghcjs)

76 if flag(use-warp) && (os(linux) || os(osx))

80 if flag(use-warp) && (os(linux) || os(osx))

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