reflex-dom-core 0.5.3 → 0.8.1.4
raw patch · 31 files changed
Files
- ChangeLog.md +112/−15
- LICENSE +1/−1
- reflex-dom-core.cabal +73/−40
- src-ghcjs/Foreign/JavaScript/Internal/Utils.hs +7/−0
- src/Foreign/JavaScript/TH.hs +8/−435
- src/Reflex/Dom/Builder/Class.hs +38/−27
- src/Reflex/Dom/Builder/Class/Events.hs +18/−5
- src/Reflex/Dom/Builder/Hydratable.hs +4/−13
- src/Reflex/Dom/Builder/Immediate.hs +195/−97
- src/Reflex/Dom/Builder/InputDisabled.hs +0/−10
- src/Reflex/Dom/Builder/Static.hs +52/−26
- src/Reflex/Dom/Class.hs +4/−7
- src/Reflex/Dom/Location.hs +23/−3
- src/Reflex/Dom/Main.hs +41/−12
- src/Reflex/Dom/Old.hs +2/−4
- src/Reflex/Dom/Prerender.hs +53/−78
- src/Reflex/Dom/WebSocket.hs +6/−10
- src/Reflex/Dom/WebSocket/Foreign.hs +2/−3
- src/Reflex/Dom/WebSocket/Query.hs +3/−3
- src/Reflex/Dom/Widget/Basic.hs +4/−15
- src/Reflex/Dom/Widget/Input.hs +13/−15
- src/Reflex/Dom/Widget/Lazy.hs +3/−3
- src/Reflex/Dom/Widget/Resize.hs +5/−6
- src/Reflex/Dom/Xhr.hs +22/−22
- src/Reflex/Dom/Xhr/Exception.hs +1/−4
- src/Reflex/Dom/Xhr/Foreign.hs +2/−3
- src/Reflex/Dom/Xhr/FormData.hs +15/−4
- src/Reflex/Dom/Xhr/ResponseType.hs +1/−4
- test/gc.hs +2/−3
- test/hlint.hs +4/−1
- test/hydration.hs +501/−88
ChangeLog.md view
@@ -1,44 +1,141 @@ # Revision history for reflex-dom-core -## 0.5.3+## 0.8.1.4+* Support hashable 1.5 in JS backend -* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:+## 0.8.1.3+* Fixes for JS backend FFI - * `Link`- * `button`- * `dtdd`- * `linkClass`- * `link`- * `tabDisplay`- * `tableDynAttr`+## 0.8.1.2+* Support GHC 9.12 - And in `Reflex.Dom.Widget.Input`:+## 0.8.1.1+* Support GHC 9.10 - * `TextInput`- * `TextAreaConfig`- * `CheckboxConfig`- * `FileInput`+## 0.8.1.0 - * Add `< 0.7` upper bound for reflex+* Add functions for managing history (popHistoryState and manageHistoryExposingExternalUpdates) +## 0.8.0.0-r1++* Loosen lens version bounds++## 0.8.0.0++* Support reflex 0.9+* *Breaking change*: tableDynAttr now requires an `Eq` constraint on the row value type+* *Breaking change*: all of the virtualList functions in Reflex.Dom.Widget.Lazy now require an `Eq` constraint on the row value type++## 0.7.0.3++* Loosen version bounds of aeson, ref-tf and constraints++## 0.7.0.2++* Require reflex >= 0.8.2.1 and switch to `commutative-semigroups`++## 0.7.0.1++* Add a variant of `postForms` that allows the `XhrRequestConfig` to be specified.++## 0.7.0.0++* ([#429](https://github.com/reflex-frp/reflex-dom/pull/429)) **(Breaking change)** Remove HasJS, HasJSContext and MonadJS. This change also removes the `js` type parameter from `Prerender`. Change `Prerender js t m` to `Prerender t m`.+ * `Reflex.Dom.WebSocket.Foreign.newWebSocket` takes one fewer argument: the first argument used to be a js context++## 0.6.3.0++* Remove calls to `eval` in Reflex.Dom.Builder.Immediate when compiling with ghcjs++## 0.6.2.1++* Fix hlint complaints with newer GHC.++## 0.6.2.0++* ([#400](https://github.com/reflex-frp/reflex-dom/pull/400/files)) Set value of input elements in static renderer++## 0.6.1.0++* Bump version bounds+* Update for new dependent-map and dependent-sum version (after the "some" package split)+* Add `MonadAtomicRef` instance for `UnrunnableT`+* Fix ([#467](https://github.com/reflex-frp/reflex-dom/issues/467)): Prevent multiple firings of XHR response event+* Updates for GHC 8.10+* Move `HasSetValue` from Reflex.Dom.Widget.Input to Reflex.Dom.Builder.Class and add an instance for `TextAreaElementConfig`+* Add `now` to the `MonadHold` instance for `UnrunnableT`+++## 0.6.0.0++* ([#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`.+* ([#374](https://github.com/reflex-frp/reflex-dom/pull/374)) **(Breaking change)** Provide text clipboard data as value of `Paste` event.+* ([#348](https://github.com/reflex-frp/reflex-dom/pull/348)) **(Breaking change)** Make XHR response headers case insensitive by changing `_xhrResponse_headers :: Map Text Text` to `_xhrResponse_headers :: Map (CI Text) Text`.+* ([#225](https://github.com/reflex-frp/reflex-dom/pull/225)) **(Breaking change)** Add a functional dependency to `HasDomEvent`.+* ([#342](https://github.com/reflex-frp/reflex-dom/issues/342)) **(Breaking change)** The mouse wheel event is now a `WheelEventResult` rather than `()`. This provides information about the wheel's motion beyond the fact that it merely moved.+* ([#353](https://github.com/reflex-frp/reflex-dom/pull/353)) Support GHC 8.8.+* ([#358](https://github.com/reflex-frp/reflex-dom/pull/358)) Fix attribute support for explicitly namespaced elements.+* ([#363](https://github.com/reflex-frp/reflex-dom/pull/363)) Remove deprecation warnings for the following widgets in+ `Reflex.Dom.Widget.Basic`:+ * `Link`+ * `button`+ * `dtdd`+ * `linkClass`+ * `link`+ * `tabDisplay`+ * `tableDynAttr`+* ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)) Fix bug in hydration causing the JavaScript to crash when dealing with unexpected HTML.+* ([#310](https://github.com/reflex-frp/reflex-dom/issues/310)) Fix the static rendering of which dropdown value is selected.+* ([#364](https://github.com/reflex-frp/reflex-dom/pull/364)) Export attributes used for controlling hydration at the element level:+ * "data-ssr" is now available as `Reflex.Dom.Builder.Immediate.hydratableAttribute`.+ * "data-hydration-skip" is now available as `Reflex.Dom.Builder.Immediate.skipHydrationAttribute`.+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.++## 0.5.3++* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:+ * `Link`+ * `button`+ * `dtdd`+ * `linkClass`+ * `link`+ * `tabDisplay`+ * `tableDynAttr`++ And in `Reflex.Dom.Widget.Input`:+ * `TextInput`+ * `TextAreaConfig`+ * `CheckboxConfig`+ * `FileInput`+* Add `< 0.7` upper bound for `reflex`.+ ## 0.5.2 * Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).+ * Update version bounds of base, containers, and stm+ * Update to use the newly split `these`/`semialign` packages. To use the pre-split `these` package, set the `split-these` flag to false.+ * Reintroduce "data-ssr": elements without this attribute are skipped during hydration.+ * Fix an issue in the hydration tests that prevented the test from finding the chromium executable+ * Relax constraints on `dyn` and `widgetHold` to match the ones in `networkView` and `networkHold` respectively+ * Fix prerender for RequesterT so that it doesn't accidentally discard a request that is made at the same moment as getPostBuild's Event fires ## 0.5.1 * Added support for marking elements with a "data-skip-hydration" attribute, which will cause hydration to ignore and skip over them.+ * Removed "data-ssr" attributes from statically rendered output. ## 0.5 * Add HydrationDomBuilderT to support hydration of statically rendered DOM nodes. See the note at the top of Reflex.Dom.Builder.Immediate.+ * As a result of the hydration changes, the Prerender class has changed, the type of `prerender` has changed and it is now a class method.+ * Add the Reflex.Dom.Xhr.FormData module to make posting formdata over xhr more convenient.
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015, Obsidian Systems LLC+Copyright (c) 2020, Obsidian Systems LLC All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
reflex-dom-core.cabal view
@@ -1,7 +1,18 @@+cabal-version: 1.24 Name: reflex-dom-core-Version: 0.5.3+Version: 0.8.1.4 Synopsis: Functional Reactive Web Apps with Reflex-Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine+Description:+ Web applications without callbacks or side-effects.+ Reflex-DOM brings the power of functional reactive programming (FRP) to the web.+ Build HTML and other Document Object Model (DOM) data with a pure functional interface.+ .+ Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.+ .+ The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the+ correct set of dependencies for each target platform (GHCJS, WebKitGTK, WASM, mobile, etc.).+ Libraries should depend on @reflex-dom-core@ and executables will usually depend on @reflex-dom@.+ All of @reflex-dom-core@'s modules are re-exported by @reflex-dom@. License: BSD3 License-file: LICENSE Author: Ryan Trinkle@@ -9,7 +20,6 @@ Stability: Experimental Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface Build-type: Simple-Cabal-version: >=1.9.2 -- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs src-ghcjs/Foreign/JavaScript/Internal/Utils.hs@@ -44,59 +54,76 @@ manual: False default: True +flag hydration-tests+ description: Whether to run the hydration tests (currently only available on linux)+ default: True+ manual: True++flag gc-tests+ description: Whether to run the gc tests (currently only available on linux)+ default: True+ manual: True++flag hlint-tests+ description: Whether to run the hlint tests+ default: False+ manual: True+ library hs-source-dirs: src build-depends:- aeson >= 0.8 && < 1.5,- base >= 4.7 && < 4.13,+ aeson >= 0.8 && < 2.3,+ base >= 4.7 && < 4.22, bifunctors >= 4.2 && < 6,- bimap >= 0.3 && < 0.4,- blaze-builder,- bytestring == 0.10.*,- containers >= 0.6 && < 0.7,- constraints >= 0.9 && < 0.12,+ bimap >= 0.3 && < 0.6,+ blaze-builder >= 0.4.1 && < 0.5,+ bytestring >= 0.10 && < 0.13,+ case-insensitive < 1.3,+ commutative-semigroups >=0.1 && <0.3,+ containers >= 0.6 && < 0.8,+ constraints >= 0.9 && < 0.15, contravariant >= 1.4 && < 1.6,- data-default >= 0.5 && < 0.8,- dependent-map >= 0.3 && < 0.4,- dependent-sum >= 0.6 && < 0.7,- dependent-sum-template >= 0.1 && < 0.2,+ data-default >= 0.5 && < 0.9,+ dependent-map >= 0.3 && < 0.5,+ dependent-sum >= 0.6 && < 0.8,+ dependent-sum-template >= 0.1 && < 0.3, directory >= 1.2 && < 1.4, exception-transformers == 0.4.*, ghcjs-dom >= 0.9.1.0 && < 0.10, jsaddle >= 0.9.0.0 && < 0.10, -- keycode-0.2 has a bug on firefox keycode >= 0.2.1 && < 0.3,- lens >= 4.7 && < 5,+ lens >= 4.7 && < 5.4, monad-control >= 1.0.1 && < 1.1,- mtl >= 2.1 && < 2.3,- primitive >= 0.5 && < 0.7,- random,- ref-tf == 0.4.*,- reflex >= 0.6.2 && < 0.7,- semigroups >= 0.16 && < 0.19,+ mtl >= 2.1 && < 2.4,+ primitive >= 0.5 && < 0.10,+ random >= 1.1 && < 1.4,+ ref-tf >= 0.4 && < 0.6,+ reflex >= 0.8.2.1 && < 1,+ semigroups >= 0.16 && < 0.21, stm >= 2.4 && < 2.6,- text == 1.2.*,- transformers >= 0.3 && < 0.6,+ text >= 1.2 && < 2.2,+ transformers >= 0.3 && < 0.7, network-uri >= 2.6.1 && < 2.7, zenc == 0.1.* - if impl(ghcjs)+ if impl(ghcjs) || arch(javascript) hs-source-dirs: src-ghcjs build-depends: ghcjs-base,- hashable == 1.2.*+ hashable >= 1.2 && < 1.6 else hs-source-dirs: src-ghc if !os(windows)- build-depends: unix == 2.7.*+ build-depends: unix >= 2.7 && <2.9 if flag(split-these) build-depends:- semialign >= 1 && < 1.1,- these >= 1 && < 1.1+ semialign >= 1 && < 1.4,+ these >= 1 && < 1.3 else build-depends:- these >= 0.4 && < 0.9+ these >= 0.4 && < 1.0 exposed-modules: Foreign.JavaScript.TH@@ -132,7 +159,8 @@ Reflex.Dom.Xhr.ResponseType Reflex.Dom.Xhr.Exception - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively+ default-language: Haskell98+ ghc-options: -Wall -fwarn-tabs -Wredundant-constraints -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively ghc-prof-options: -fprof-auto if flag(expose-all-unfoldings)@@ -146,26 +174,29 @@ if flag(use-template-haskell) build-depends:- dependent-sum >= 0.6,- dependent-sum-template >= 0.1 && < 0.2,- template-haskell+ dependent-sum-template >= 0.1 && < 0.3,+ template-haskell >= 2.12.0 && < 2.24 other-extensions: TemplateHaskell cpp-options: -DUSE_TEMPLATE_HASKELL other-modules: Reflex.Dom.Builder.Class.TH- else- build-depends:- dependent-sum == 0.6.* test-suite hlint- build-depends: base, hlint+ build-depends:+ base,+ hlint >= 2.0 && < 4.0,+ reflex-dom-core hs-source-dirs: test main-is: hlint.hs type: exitcode-stdio-1.0+ default-language: Haskell98+ if !flag(hlint-tests)+ buildable: False test-suite hydration build-depends: base , aeson+ , async , bytestring , chrome-test-utils , constraints@@ -203,11 +234,12 @@ , websockets , which hs-source-dirs: test- ghc-options: -rtsopts -with-rtsopts=-T -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans+ ghc-options: -rtsopts "-with-rtsopts=-T -V0" -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans ghc-prof-options: -fprof-auto -optP-DPROFILING main-is: hydration.hs type: exitcode-stdio-1.0- if !os(linux) || !arch(x86_64) || flag(profile-reflex)+ default-language: Haskell98+ if !os(linux) || !arch(x86_64) || flag(profile-reflex) || !flag(hydration-tests) buildable: False -- broken test on base 4.11 & ghc 8.4.3@@ -226,7 +258,8 @@ ghc-prof-options: -fprof-auto -optP-DPROFILING main-is: gc.hs type: exitcode-stdio-1.0- if !os(linux) || !arch(x86_64)+ default-language: Haskell98+ if !os(linux) || !arch(x86_64) || !flag(gc-tests) buildable: False source-repository head
src-ghcjs/Foreign/JavaScript/Internal/Utils.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}+#ifdef __ghcjs_HOST_OS {-# LANGUAGE JavaScriptFFI #-}+#endif module Foreign.JavaScript.Internal.Utils ( synchronously@@ -9,7 +12,11 @@ import GHCJS.Concurrent import GHCJS.DOM.Types (JSM, JSVal, RequestAnimationFrameCallback (..))+#if __GLASGOW_HASKELL__ < 900 import GHCJS.Foreign.Callback (releaseCallback)+#else+import GHC.JS.Foreign.Callback (releaseCallback)+#endif freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM () freeRequestAnimationFrameCallback (RequestAnimationFrameCallback cb) = releaseCallback cb
src/Foreign/JavaScript/TH.hs view
@@ -1,18 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_TEMPLATE_HASKELL-{-# LANGUAGE TemplateHaskell #-}-#endif #ifdef ghcjs_HOST_OS {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE JavaScriptFFI #-}@@ -27,27 +22,25 @@ import Prelude hiding ((!!)) import Reflex.Class import Reflex.Adjustable.Class-import Reflex.DynamicWriter.Base-import Reflex.EventWriter.Base import Reflex.Host.Class-import Reflex.PerformEvent.Base import Reflex.PerformEvent.Class-import Reflex.PostBuild.Base-import Reflex.Requester.Base-import Reflex.Query.Base (QueryT (..)) #ifdef USE_TEMPLATE_HASKELL import Language.Haskell.TH #endif -import GHCJS.DOM.Types (JSContextRef, Node (..), askJSM)+import GHCJS.DOM.Types (JSContextRef, askJSM) #ifdef ghcjs_HOST_OS import qualified GHCJS.Buffer as JS import GHCJS.DOM.Types (MonadJSM) import qualified GHCJS.DOM.Types as JS import qualified GHCJS.Foreign as JS+#if __GLASGOW_HASKELL__ < 900 import qualified GHCJS.Foreign.Callback as JS import qualified GHCJS.Foreign.Callback.Internal (Callback (..))+#else+import qualified GHC.JS.Foreign.Callback as JS+#endif import qualified JavaScript.Array as JS import qualified JavaScript.Array.Internal (SomeJSArray (..)) import qualified JavaScript.Object as JS@@ -60,75 +53,18 @@ import Foreign.Ptr import Text.Encoding.Z #else-import Control.Lens.Operators ((^.))-import Data.Word (Word8)-import GHCJS.DOM.Types (JSVal, MonadJSM (..), liftJSM, runJSM, toJSString, toJSVal)-import Language.Javascript.JSaddle (Function (..), array, eval, freeFunction, function, js, js1, jss, valBool,- valIsNull, valIsUndefined, valMakeNumber, valMakeString, valToBool,- valToNumber, valToText, valUndefined, (!!))+import GHCJS.DOM.Types (MonadJSM (..), runJSM) #endif -import Control.Concurrent-import Control.Monad import Control.Monad.Exception import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref-import Control.Monad.State-import qualified Control.Monad.State.Strict as Strict import Control.Monad.Trans.Control-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS import Data.Coerce (coerce)-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T -class Monad m => HasJSContext m where- type JSContextPhantom m :: *- askJSContext :: m (JSContextSingleton (JSContextPhantom m))--type HasWebView = HasJSContext--- Not sure if we should deprecate this {-# DEPRECATED HasWebView "Use HasJSContext" #-}--instance HasJSContext m => HasJSContext (ReaderT r m) where- type JSContextPhantom (ReaderT r m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJSContext m => HasJSContext (StateT r m) where- type JSContextPhantom (StateT r m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJSContext m => HasJSContext (Strict.StateT r m) where- type JSContextPhantom (Strict.StateT r m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJSContext m => HasJSContext (PostBuildT t m) where- type JSContextPhantom (PostBuildT t m) = JSContextPhantom m- askJSContext = lift askJSContext--instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEventT t m) where- type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)- askJSContext = PerformEventT $ lift askJSContext--instance HasJSContext m => HasJSContext (EventWriterT t w m) where- type JSContextPhantom (EventWriterT t w m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where- type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJSContext m => HasJSContext (RequesterT t request response m) where- type JSContextPhantom (RequesterT t request response m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJSContext m => HasJSContext (QueryT t q m) where- type JSContextPhantom (QueryT t q m) = JSContextPhantom m- askJSContext = QueryT askJSContext- newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException) instance PrimMonad m => PrimMonad (WithJSContextSingleton x m) where@@ -191,10 +127,6 @@ runWithJSContextSingleton :: WithJSContextSingleton x m a -> JSContextSingleton x -> m a runWithJSContextSingleton = runReaderT . unWithJSContextSingleton -instance (Monad m) => HasJSContext (WithJSContextSingleton x m) where- type JSContextPhantom (WithJSContextSingleton x m) = x- askJSContext = WithJSContextSingleton ask- instance MonadRef m => MonadRef (WithJSContextSingleton x m) where type Ref (WithJSContextSingleton x m) = Ref m newRef = lift . newRef@@ -214,368 +146,9 @@ -- | A singleton type for a given JSContext; we use this to statically guarantee that different JSContexts don't get mixed up newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef } -#ifdef ghcjs_HOST_OS-type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal-newtype JSFFI = JSFFI JSFFI_Internal-#else-newtype JSFFI = JSFFI String-#endif--data JSFun x = JSFun { unJSFun :: JSRef x #ifndef ghcjs_HOST_OS- , unJSFunction :: Function-#endif- }--instance ToJS x (JSFun x) where- withJS r f = f (unJSFun r)--class IsJSContext x where- data JSRef x--class (Monad m, MonadJSM (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where- type JSX m :: * -> *- liftJS :: JSX m a -> m a--instance HasJS x m => HasJS x (ReaderT r m) where- type JSX (ReaderT r m) = JSX m- liftJS = lift . liftJS--instance HasJS x m => HasJS x (PostBuildT t m) where- type JSX (PostBuildT t m) = JSX m- liftJS = lift . liftJS--instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where- type JSX (PerformEventT t m) = JSX (HostFrame t)- liftJS = PerformEventT . lift . liftJS--instance HasJS x m => HasJS x (DynamicWriterT t w m) where- type JSX (DynamicWriterT t w m) = JSX m- liftJS = lift . liftJS--instance HasJS x m => HasJS x (EventWriterT t w m) where- type JSX (EventWriterT t w m) = JSX m- liftJS = lift . liftJS--instance HasJS x m => HasJS x (RequesterT t request response m) where- type JSX (RequesterT t request response m) = JSX m- liftJS = lift . liftJS--instance HasJS x m => HasJS x (QueryT t q m) where- type JSX (QueryT t q m) = JSX m- liftJS = lift . liftJS---- | A Monad that is capable of executing JavaScript-class Monad m => MonadJS x m | m -> x where- runJS :: JSFFI -> [JSRef x] -> m (JSRef x)- forkJS :: m () -> m ThreadId- mkJSUndefined :: m (JSRef x)- isJSNull :: JSRef x -> m Bool- isJSUndefined :: JSRef x -> m Bool- fromJSBool :: JSRef x -> m Bool- fromJSString :: JSRef x -> m String- fromJSArray :: JSRef x -> m [JSRef x]- fromJSUint8Array :: JSRef x -> m ByteString- fromJSNumber :: JSRef x -> m Double- withJSBool :: Bool -> (JSRef x -> m r) -> m r- withJSString :: String -> (JSRef x -> m r) -> m r- withJSNumber :: Double -> (JSRef x -> m r) -> m r- withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r- withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r- -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS- mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions- freeJSFun :: JSFun x -> m ()- setJSProp :: String -> JSRef x -> JSRef x -> m ()- getJSProp :: String -> JSRef x -> m (JSRef x)- withJSNode :: Node -> (JSRef x -> m r) -> m r--#ifdef ghcjs_HOST_OS--data JSCtx_IO-type JS' = JSCtx_IO--instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where- type JSX (WithJSContextSingleton x m) = IO- liftJS = liftIO--instance IsJSContext JSCtx_IO where- newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }--instance MonadJS JSCtx_IO IO where- runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)- forkJS = forkIO- mkJSUndefined = return $ JSRef_IO JS.jsUndefined- isJSNull (JSRef_IO r) = return $ JS.isNull r- isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r- fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r- fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r- fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r- fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable- fromJSNumber (JSRef_IO r) = JS.fromJSValUnchecked r- withJSBool b f = f $ JSRef_IO $ JS.toJSBool b- withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s- withJSNumber n f = do- r <- JS.toJSVal n- f $ JSRef_IO r- withJSArray l f = do- r <- JS.fromListIO $ coerce l- f $ JSRef_IO $ coerce r- withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do- ba <- extractByteArray cStr $ BS.length payload- f $ JSUint8Array $ JSRef_IO ba- mkJSFun f = do- cb <- JS.syncCallback1' $ \args -> do- l <- JS.toListIO $ coerce args- JSRef_IO result <- f $ coerce l- return result- fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb- freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r- setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o- getJSProp s (JSRef_IO o) = do- r <- JS.getProp (JS.toJSString s) $ coerce o- return $ JSRef_IO r- withJSNode n f = f $ JSRef_IO $ unNode n--foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal--foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal--#else--data JSCtx_JavaScriptCore x-type JS' = JSCtx_JavaScriptCore ()--instance IsJSContext (JSCtx_JavaScriptCore x) where- newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }--instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x m) where- type JSX (WithJSContextSingleton x m) = WithJSContextSingleton x IO- liftJS a = do- wv <- askJSContext- liftIO $ runWithJSContextSingleton a wv--newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)--runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a-runWithJSContext = runReaderT . unWithJSContext- instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where liftJSM' f = do- wv <- askJSContext+ wv <- WithJSContextSingleton ask runJSM f $ unJSContextSingleton wv--instance MonadIO m => MonadJSM (WithJSContext x m) where- liftJSM' f =- runJSM f =<< WithJSContext ask--lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a-lowerWithJSContext a = do- c <- askJSM- liftIO $ runWithJSContext a c--liftWithJSContextSingletonThroughWithJSContext :: (HasJSContext m, MonadJSM m, MonadTrans t, Monad m1)- => ((t1 -> t m1 a) -> WithJSContext x IO b)- -> (t1 -> WithJSContextSingleton (JSContextPhantom m) m1 a)- -> m b-liftWithJSContextSingletonThroughWithJSContext f a = do- wv <- askJSContext- lowerWithJSContext $ f $ \b' -> lift $ runWithJSContextSingleton (a b') wv--instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x IO) where- forkJS a = do- wv <- askJSContext- liftIO $ forkIO $ runWithJSContextSingleton a wv- mkJSFun a = do- wv <- askJSContext- lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithJSContextSingleton (a args) wv- runJS expr args = lowerWithJSContext $ runJS expr args- mkJSUndefined = lowerWithJSContext mkJSUndefined- isJSNull = lowerWithJSContext . isJSNull- isJSUndefined = lowerWithJSContext . isJSUndefined- fromJSBool = lowerWithJSContext . fromJSBool- fromJSString = lowerWithJSContext . fromJSString- fromJSArray = lowerWithJSContext . fromJSArray- fromJSUint8Array = lowerWithJSContext . fromJSUint8Array- fromJSNumber = lowerWithJSContext . fromJSNumber- freeJSFun = lowerWithJSContext . freeJSFun- withJSBool = liftWithJSContextSingletonThroughWithJSContext . withJSBool- withJSString = liftWithJSContextSingletonThroughWithJSContext . withJSString- withJSNumber = liftWithJSContextSingletonThroughWithJSContext . withJSNumber- withJSArray = liftWithJSContextSingletonThroughWithJSContext . withJSArray- withJSUint8Array = liftWithJSContextSingletonThroughWithJSContext . withJSUint8Array- withJSNode = liftWithJSContextSingletonThroughWithJSContext . withJSNode- setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef- getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef--instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where- runJS (JSFFI body) args =- withJSArray args $ \(JSRef_JavaScriptCore this) -> do- result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this- return $ JSRef_JavaScriptCore result- forkJS a = do- c <- askJSM- liftIO . forkIO $ runWithJSContext a c- mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined- isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r- isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r- fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r- fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)- withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)- withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)- withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)- withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM- (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))- withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do- payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]- f $ JSUint8Array payloadRef- fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do- len <- round <$> (valToNumber =<< (a ^. js "length"))- forM [0..len-1] $ fmap JSRef_JavaScriptCore . (a !!)- fromJSUint8Array a = do- vals <- fromJSArray a- doubles <- mapM fromJSNumber vals- return $ BS.pack $ map round doubles- fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val- mkJSFun a = liftJSM $ do- ctx <- askJSM- f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx- fRef <- toJSVal f- return $ JSFun (JSRef_JavaScriptCore fRef) f- freeJSFun (JSFun _ f) = liftJSM $ freeFunction f- setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =- liftJSM $ objRef ^. jss propName valRef- getJSProp propName (JSRef_JavaScriptCore objRef) =- JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)- withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)--#endif--class FromJS x a where- fromJS :: MonadJS x m => JSRef x -> m a--instance FromJS x () where- fromJS _ = return () --TODO: Should this do some kind of checking for the js value?--instance FromJS x Bool where- fromJS = fromJSBool--instance ToJS x Bool where- withJS = withJSBool--instance FromJS x String where- fromJS = fromJSString--instance FromJS x Text where- fromJS s = T.pack <$> fromJSString s--instance FromJS x a => FromJS x (Maybe a) where- fromJS x = do- n <- isJSNull x- if n then return Nothing else Just <$> fromJS x--class ToJS x a where- withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r--instance ToJS x (JSRef x) where- withJS r = ($ r)--instance FromJS x (JSRef x) where- fromJS = return--instance ToJS x String where- withJS = withJSString--instance ToJS x Text where- withJS = withJSString . T.unpack--newtype JSArray a = JSArray { unJSArray :: [a] }--instance ToJS x a => ToJS x (JSArray a) where- withJS = withJSArrayFromList . unJSArray--instance FromJS x a => FromJS x (JSArray a) where- fromJS = fmap JSArray . mapM fromJS <=< fromJSArray--withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r-withJSArrayFromList as f = go as []- where go [] jsRefs = withJSArray (reverse jsRefs) f- go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)--newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }--instance ToJS x (JSUint8Array x) where- withJS (JSUint8Array r) = ($ r)--instance FromJS x (JSUint8Array x) where- fromJS = return . JSUint8Array--instance ToJS x Word8 where- withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions--instance ToJS x Int where- withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions--instance FromJS x Int where- fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions--instance ToJS x Double where- withJS = withJSNumber--instance FromJS x Double where- fromJS = fromJSNumber--instance ToJS x Node where- withJS = withJSNode---#ifdef USE_TEMPLATE_HASKELL--importJS :: Safety -> String -> String -> Q Type -> Q [Dec]-importJS safety body name qt = do- t <- qt- let (argTypes, _) = parseType t- argNames <- forM argTypes $ \_ -> do- arg <- newName "arg"- argRef <- newName "argRef"- return (arg, argRef)- (jsffiDecs, jsffiExp) <- mkJSFFI safety body- let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS- |]- go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]- e <- lamE (map (varP. fst) argNames) $ go argNames- let n = mkName name- return $ jsffiDecs ++- [ SigD n t- , ValD (VarP n) (NormalB e) []- ]--mkJSFFI :: Safety -> String -> Q ([Dec], Exp)-#ifdef ghcjs_HOST_OS-mkJSFFI safety body = do- -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs- l <- location- n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))- t <- [t| JSFFI_Internal |]- let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"- let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]- e <- [| JSFFI $(varE n) |]- return (decs, e)-#else-mkJSFFI _ body = do- e <- [| JSFFI body |]- return ([], e)-#endif--parseType :: Type -> ([Type], Type)-parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)- | monadJs == ''MonadJS = go funType- where go t = case t of- AppT (AppT ArrowT arg) t' ->- let (args, result) = go t'- in (arg : args, result)- AppT (VarT m') result- | m' == m -> ([], result)- _ -> error $ "parseType: can't parse type " <> show t-parseType t = error $ "parseType: can't parse type " <> show t- #endif
src/Reflex/Dom/Builder/Class.hs view
@@ -9,11 +9,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} #if !MIN_VERSION_base(4,9,0) {-# LANGUAGE ImpredicativeTypes #-}+#else+{-# LANGUAGE Rank2Types #-} -- Implied by ImpredicativeTypes #endif {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}@@ -21,6 +22,7 @@ {-# LANGUAGE TemplateHaskell #-} #endif {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Reflex.Dom.Builder.Class ( module Reflex.Dom.Builder.Class@@ -46,17 +48,19 @@ import qualified Control.Category import Control.Lens hiding (element)+import Control.Monad.Fix import Control.Monad.Reader import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import Control.Monad.Trans.Control import Data.Default import Data.Functor.Misc+import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Proxy-import Data.Semigroup+import Data.Semigroup.Commutative import Data.String import Data.Text (Text) import Data.Type.Coercion@@ -64,20 +68,20 @@ import qualified GHCJS.DOM.Types as DOM class Default (EventSpec d EventResult) => DomSpace d where- type EventSpec d :: (EventTag -> *) -> *- type RawDocument d :: *- type RawTextNode d :: *- type RawCommentNode d :: *- type RawElement d :: *- type RawInputElement d :: *- type RawTextAreaElement d :: *- type RawSelectElement d :: *+ type EventSpec d :: (EventTag -> Type) -> Type+ type RawDocument d :: Type+ type RawTextNode d :: Type+ type RawCommentNode d :: Type+ type RawElement d :: Type+ type RawInputElement d :: Type+ type RawTextAreaElement d :: Type+ type RawSelectElement d :: Type addEventSpecFlags :: proxy d -> EventName en -> (Maybe (er en) -> EventFlags) -> EventSpec d er -> EventSpec d er -- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building -- dynamic DOM in the 'Reflex' timeline @t@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable t m) => DomBuilder t m | m -> t where- type DomBuilderSpace m :: *+ type DomBuilderSpace m :: Type textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t) default textNode :: ( MonadTrans f , m ~ f m'@@ -157,7 +161,7 @@ {-# INLINABLE wrapRawElement #-} class DomBuilder t m => MountableDomBuilder t m where- type DomFragment m :: *+ type DomFragment m :: Type buildDomFragment :: m a -> m (DomFragment m, a) mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m () @@ -305,6 +309,15 @@ {-# INLINE inputElementConfig_elementConfig #-} #endif +instance (Reflex t, er ~ EventResult, DomSpace s) => Default (ElementConfig er t s) where+ {-# INLINABLE def #-}+ def = ElementConfig+ { _elementConfig_namespace = Nothing+ , _elementConfig_initialAttributes = mempty+ , _elementConfig_modifyAttributes = Nothing+ , _elementConfig_eventSpec = def+ }+ instance (Reflex t, er ~ EventResult, DomSpace s) => Default (InputElementConfig er t s) where {-# INLINABLE def #-} def = InputElementConfig@@ -540,15 +553,6 @@ {-# INLINABLE namespace #-} namespace = elementConfig_namespace -instance (Reflex t, er ~ EventResult, DomSpace s) => Default (ElementConfig er t s) where- {-# INLINABLE def #-}- def = ElementConfig- { _elementConfig_namespace = Nothing- , _elementConfig_initialAttributes = mempty- , _elementConfig_modifyAttributes = Nothing- , _elementConfig_eventSpec = def- }- instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m wrapRawElement e = lift . wrapRawElement e@@ -558,7 +562,7 @@ buildDomFragment = liftThrough buildDomFragment mountDomFragment f0 f' = lift $ mountDomFragment f0 f' -instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where+instance (DomBuilder t m, MonadFix m, Monoid w, MonadHold t m) => DomBuilder t (DynamicWriterT t w m) where type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m textNode = liftTextNode commentNode = liftCommentNode@@ -598,7 +602,7 @@ placeRawElement = lift . placeRawElement wrapRawElement e = lift . wrapRawElement e -instance (DomBuilder t m, MonadHold t m, MonadFix m, Semigroup w) => DomBuilder t (EventWriterT t w m) where+instance (DomBuilder t m, MonadHold t m, Semigroup w) => DomBuilder t (EventWriterT t w m) where type DomBuilderSpace (EventWriterT t w m) = DomBuilderSpace m textNode = liftTextNode commentNode = liftCommentNode@@ -617,7 +621,7 @@ placeRawElement = lift . placeRawElement wrapRawElement e = lift . wrapRawElement e -instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive q, Eq q) => DomBuilder t (QueryT t q m) where+instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Commutative q, Eq q) => DomBuilder t (QueryT t q m) where type DomBuilderSpace (QueryT t q m) = DomBuilderSpace m textNode = liftTextNode commentNode = liftCommentNode@@ -638,8 +642,8 @@ -- * Convenience functions -class HasDomEvent t target eventName where- type DomEventType target eventName :: *+class HasDomEvent t target eventName | target -> t where+ type DomEventType target eventName :: Type domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName) instance Reflex t => HasDomEvent t (Element EventResult d t) en where@@ -732,7 +736,6 @@ :: ( m ~ f m' , RawDocument (DomBuilderSpace m) ~ RawDocument (DomBuilderSpace m') , MonadTrans f- , Monad m' , HasDocument m' ) => m (RawDocument (DomBuilderSpace m))@@ -744,3 +747,11 @@ instance HasDocument m => HasDocument (PostBuildT t m) instance HasDocument m => HasDocument (RequesterT t request response m) instance HasDocument m => HasDocument (QueryT t q m)++class HasSetValue a where+ type SetValue a :: Type+ setValue :: Lens' a (SetValue a)++instance Reflex t => HasSetValue (TextAreaElementConfig er t m) where+ type SetValue (TextAreaElementConfig er t m) = Event t Text+ setValue = textAreaElementConfig_setValue
src/Reflex/Dom/Builder/Class/Events.hs view
@@ -11,9 +11,12 @@ #ifdef USE_TEMPLATE_HASKELL import Data.GADT.Compare.TH #else+import Data.Type.Equality ((:~:)(..)) import Data.GADT.Compare- (GOrdering(..), (:~:)(..), GEq(..), GCompare(..))+ (GOrdering(..), GEq(..), GCompare(..)) #endif+import Data.Kind (Type)+import Data.Text (Text) data EventTag = AbortTag@@ -63,7 +66,7 @@ | TouchendTag | TouchcancelTag -data EventName :: EventTag -> * where+data EventName :: EventTag -> Type where Abort :: EventName 'AbortTag Blur :: EventName 'BlurTag Change :: EventName 'ChangeTag@@ -113,7 +116,7 @@ newtype EventResult en = EventResult { unEventResult :: EventResultType en } -type family EventResultType (en :: EventTag) :: * where+type family EventResultType (en :: EventTag) :: Type where EventResultType 'ClickTag = () EventResultType 'DblclickTag = (Int, Int) EventResultType 'KeypressTag = Word@@ -151,7 +154,7 @@ EventResultType 'BeforecopyTag = () EventResultType 'CopyTag = () EventResultType 'BeforepasteTag = ()- EventResultType 'PasteTag = ()+ EventResultType 'PasteTag = Maybe Text EventResultType 'ResetTag = () EventResultType 'SearchTag = () EventResultType 'SelectstartTag = ()@@ -159,7 +162,17 @@ EventResultType 'TouchmoveTag = TouchEventResult EventResultType 'TouchendTag = TouchEventResult EventResultType 'TouchcancelTag = TouchEventResult- EventResultType 'WheelTag = ()+ EventResultType 'WheelTag = WheelEventResult++data DeltaMode = DeltaPixel | DeltaLine | DeltaPage+ deriving (Show, Read, Eq, Ord, Bounded, Enum)++data WheelEventResult = WheelEventResult+ { _wheelEventResult_deltaX :: Double+ , _wheelEventResult_deltaY :: Double+ , _wheelEventResult_deltaZ :: Double+ , _wheelEventResult_deltaMode :: DeltaMode+ } deriving (Show, Read, Eq, Ord) data TouchEventResult = TouchEventResult { _touchEventResult_altKey :: Bool
src/Reflex/Dom/Builder/Hydratable.hs view
@@ -15,16 +15,15 @@ import Control.Monad.Trans.Control import Data.Coerce import qualified Data.Map as Map-import Foreign.JavaScript.TH #ifndef ghcjs_HOST_OS import GHCJS.DOM.Types (MonadJSM (..)) #endif import Reflex import Reflex.Dom.Builder.Class-import Reflex.Dom.Builder.Immediate (HasDocument (..))+import Reflex.Dom.Builder.Immediate (hydratableAttribute) import Reflex.Host.Class --- | A DomBuilder transformer that adds "data-ssr" to all elements such that the+-- | A DomBuilder transformer that adds an attribute to all elements such that the -- hydration builder knows which bits of DOM were added by us, and which were -- added by external scripts. newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)@@ -62,8 +61,8 @@ makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m makeHydratable cfg = cfg- { _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg- , _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg+ { _elementConfig_initialAttributes = Map.insert hydratableAttribute "" $ _elementConfig_initialAttributes cfg+ , _elementConfig_modifyAttributes = fmap (Map.delete hydratableAttribute) <$> _elementConfig_modifyAttributes cfg } instance PostBuild t m => PostBuild t (HydratableT m) where@@ -101,14 +100,6 @@ lift $ selectElement cfg' $ runHydratableT child instance HasDocument m => HasDocument (HydratableT m)--instance HasJSContext m => HasJSContext (HydratableT m) where- type JSContextPhantom (HydratableT m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJS js m => HasJS js (HydratableT m) where- type JSX (HydratableT m) = JSX m- liftJS = lift . liftJS instance DomRenderHook t m => DomRenderHook t (HydratableT m) where withRenderHook f = HydratableT . withRenderHook f . runHydratableT
src/Reflex/Dom/Builder/Immediate.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}@@ -49,6 +48,7 @@ , HydrationMode (..) , HydrationRunnerT (..) , runHydrationRunnerT+ , runHydrationRunnerTWithFailure , ImmediateDomBuilderT , runHydrationDomBuilderT , getHydrationMode@@ -107,6 +107,9 @@ , WindowConfig (..) , Window (..) , wrapWindow+ -- * Attributes for controlling hydration+ , hydratableAttribute+ , skipHydrationAttribute -- * Internal , traverseDMapWithKeyWithAdjust' , hoistTraverseWithKeyWithAdjust@@ -117,7 +120,9 @@ import Control.Concurrent import Control.Exception (bracketOnError) import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)+import Control.Monad import Control.Monad.Exception+import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref@@ -126,35 +131,38 @@ import Data.Default import Data.Dependent.Map (DMap) import Data.Dependent.Sum-import Data.FastMutableIntMap (PatchIntMap (..)) import Data.Foldable (for_, traverse_) import Data.Functor.Compose import Data.Functor.Constant import Data.Functor.Misc import Data.Functor.Product+import Data.GADT.Compare (GCompare) import Data.IORef import Data.IntMap.Strict (IntMap)+import Data.Kind (Type) import Data.Maybe-import Data.Monoid ((<>)) import Data.Some (Some(..))+import Data.String (IsString) import Data.Text (Text) import Foreign.JavaScript.Internal.Utils import Foreign.JavaScript.TH+import GHCJS.DOM.ClipboardEvent as ClipboardEvent import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)-import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute) import GHCJS.DOM.EventM (EventM, event, on) import GHCJS.DOM.KeyboardEvent as KeyboardEvent import GHCJS.DOM.MouseEvent import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)-import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)+import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, FocusEvent, IsElement, IsEvent, IsNode, Node, TouchEvent, WheelEvent, uncheckedCastTo) import GHCJS.DOM.UIEvent-import Language.Javascript.JSaddle (call, eval)+#ifndef ghcjs_HOST_OS+import Language.Javascript.JSaddle (call, eval) -- Avoid using eval in ghcjs. Use ffi instead+#endif import Reflex.Adjustable.Class import Reflex.Class as Reflex import Reflex.Dom.Builder.Class import Reflex.Dynamic import Reflex.Host.Class-import Reflex.Patch.DMapWithMove (PatchDMapWithMove(..)) import Reflex.Patch.MapWithMove (PatchMapWithMove(..)) import Reflex.PerformEvent.Base (PerformEventT) import Reflex.PerformEvent.Class@@ -175,6 +183,7 @@ import qualified Data.Map as Map import qualified Data.Text as T import qualified GHCJS.DOM as DOM+import qualified GHCJS.DOM.DataTransfer as DataTransfer import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events import qualified GHCJS.DOM.DocumentOrShadowRoot as Document import qualified GHCJS.DOM.Element as Element@@ -192,6 +201,7 @@ import qualified GHCJS.DOM.TouchList as TouchList import qualified GHCJS.DOM.Types as DOM import qualified GHCJS.DOM.Window as Window+import qualified GHCJS.DOM.WheelEvent as WheelEvent import qualified Reflex.Patch.DMap as PatchDMap import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove import qualified Reflex.Patch.MapWithMove as PatchMapWithMove@@ -273,7 +283,7 @@ } {-# INLINABLE localRunner #-}-localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a+localRunner :: MonadJSM m => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a localRunner (HydrationRunnerT m) s parent = do s0 <- HydrationRunnerT get (a, s') <- HydrationRunnerT $ lift $ local (\_ -> parent) $ runStateT m (s0 { _hydrationState_previousNode = s })@@ -283,14 +293,23 @@ {-# INLINABLE runHydrationRunnerT #-} runHydrationRunnerT- :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))+ :: (MonadRef m, Ref m ~ IORef, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m)) => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a-runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do+runHydrationRunnerT m = runHydrationRunnerTWithFailure m (pure ())++{-# INLINABLE runHydrationRunnerTWithFailure #-}+runHydrationRunnerTWithFailure+ :: (MonadRef m, Ref m ~ IORef, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))+ => HydrationRunnerT t m a -> IO () -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a+runHydrationRunnerTWithFailure (HydrationRunnerT m) onFailure s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do (a, s') <- runStateT m (HydrationState s False) traverse_ removeSubsequentNodes $ _hydrationState_previousNode s' 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."+ when (_hydrationState_failed s') $ liftIO onFailure pure a ++ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where {-# INLINABLE newEventWithTrigger #-} newEventWithTrigger = lift . newEventWithTrigger@@ -314,12 +333,11 @@ -- done *before* the switchover to immediate mode - this is most likely some -- form of 'hold' which we want to remove after hydration is done {-# INLINABLE addHydrationStepWithSetup #-}-addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()+addHydrationStepWithSetup :: MonadIO m => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m () addHydrationStepWithSetup setup f = getHydrationMode >>= \case HydrationMode_Immediate -> pure () HydrationMode_Hydrating -> do- switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover- (s, _) <- lift $ runWithReplace setup $ return () <$ switchover+ s <- lift setup addHydrationStep (f s) -- | Add a hydration step@@ -339,7 +357,7 @@ {-# INLINABLE runDomRenderHookT #-} runDomRenderHookT- :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)+ :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef) => DomRenderHookT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a@@ -371,7 +389,6 @@ :: ( MonadFix m , PerformEvent t m , MonadReflexCreateTrigger t m- , MonadJSM m , MonadJSM (Performable m) , MonadRef m , Ref m ~ IORef@@ -443,9 +460,21 @@ -- | Remove all nodes after given node removeSubsequentNodes :: (MonadJSM m, IsNode n) => n -> m ()+#ifdef ghcjs_HOST_OS+--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2021-11-06)+foreign import javascript unsafe+#if __GLASGOW_HASKELL__ < 900+ "(function() { var n = $1; while (n['nextSibling']) { n['parentNode']['removeChild'](n['nextSibling']); }; })()"+#else+ "(function(n) { while (n['nextSibling']) { n['parentNode']['removeChild'](n['nextSibling']); }; })"+#endif+ removeSubsequentNodes_ :: DOM.Node -> IO ()+removeSubsequentNodes n = liftJSM $ removeSubsequentNodes_ (toNode n)+#else removeSubsequentNodes n = liftJSM $ do f <- eval ("(function(n) { while (n.nextSibling) { (n.parentNode).removeChild(n.nextSibling); }; })" :: Text) void $ call f f [n]+#endif -- | s and e must both be children of the same node and s must precede e; -- all nodes between s and e will be removed, but s and e will not be removed@@ -458,9 +487,21 @@ -- nodes between s and e will be moved into the given DocumentFragment, but s -- and e will not be moved extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()+#ifdef ghcjs_HOST_OS+--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2021-11-06)+foreign import javascript unsafe+#if __GLASGOW_HASKELL__ < 900+ "(function() { var df = $1; var s = $2; var e = $3; var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })()"+#else+ "(function(df, s, e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })"+#endif+ extractBetweenExclusive_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()+extractBetweenExclusive df s e = liftJSM $ extractBetweenExclusive_ df (toNode s) (toNode e)+#else extractBetweenExclusive df s e = liftJSM $ do f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text) void $ call f f (df, s, e)+#endif -- | s and e must both be children of the same node and s must precede e; -- s and all nodes between s and e will be removed, but e will not be removed@@ -474,7 +515,11 @@ #ifdef ghcjs_HOST_OS --NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04) foreign import javascript unsafe+#if __GLASGOW_HASKELL__ < 900 "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"+#else+ "(function($1, x, $3) { while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })"+#endif extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO () extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e) #else@@ -504,7 +549,7 @@ -- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself {-# INLINE wrap #-} wrap- :: forall s m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m, EventSpec s ~ GhcjsEventSpec)+ :: forall s m er t. (MonadJSM m, DomRenderHook t m, EventSpec s ~ GhcjsEventSpec) => Chan [DSum (EventTriggerRef t) TriggerInvocation] -> DOM.Element -> RawElementConfig er t s@@ -628,7 +673,7 @@ newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> JSM (EventFlags, JSM (Maybe (er en)))) -data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)+data Pair1 (f :: k -> Type) (g :: k -> Type) (a :: k) = Pair1 (f a) (g a) data Maybe1 f a = Nothing1 | Just1 (f a) @@ -743,6 +788,14 @@ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a) #-} +-- | An attribute which causes hydration to skip over an element completely.+skipHydrationAttribute :: IsString s => s+skipHydrationAttribute = "data-hydration-skip"++-- | An attribute which signals that an element should be hydrated.+hydratableAttribute :: IsString s => s+hydratableAttribute = "data-ssr"+ {-# INLINE hydrateElement #-} hydrateElement :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)@@ -764,18 +817,15 @@ } result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env' wrapResult <- liftIO newEmptyMVar- let skipAttr = "data-hydration-skip" :: DOM.JSString- ssrAttr = "data-ssr" :: DOM.JSString+ let -- Determine if we should skip an element. We currently skip elements for+ -- two reasons:+ -- 1) it was not produced by a static builder which supports hydration+ -- 2) it is explicitly marked to be skipped shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool- shouldSkip e = case cfg ^. namespace of- Nothing -> do- skip <- hasAttribute e skipAttr- ssr <- hasAttribute e ssrAttr- pure $ skip || not ssr- Just ns -> do- skip <- hasAttributeNS e (Just ns) skipAttr- ssr <- hasAttributeNS e (Just ns) ssrAttr- pure $ skip || not ssr+ shouldSkip e = do+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)+ pure $ skip || not hydratable childDom <- liftIO $ readIORef childDelayedRef let rawCfg = extractRawElementConfig cfg doc <- askDocument@@ -791,7 +841,7 @@ Just node -> DOM.castTo DOM.Element node >>= \case Nothing -> go (Just node) -- this node is not an element, skip Just e -> shouldSkip e >>= \case- True -> go (Just node) -- this element is explicitly marked for being skipped by hydration+ True -> go (Just node) -- this element should be skipped by hydration False -> do t <- Element.getTagName e -- TODO: check attributes?@@ -915,14 +965,26 @@ doc <- askDocument -- Expected initial value from config let v0 = _inputElementConfig_initialValue cfg- addHydrationStep $ do+ c0 = _inputElementConfig_initialChecked cfg+ valuesAtSwitchover = do+ v <- maybe (pure $ pure v0) (hold v0) (_inputElementConfig_setValue cfg)+ c <- maybe (pure $ pure c0) (hold c0) (_inputElementConfig_setChecked cfg)+ pure (v, c)+ addHydrationStepWithSetup valuesAtSwitchover $ \(switchoverValue', switchoverChecked') -> do+ switchoverValue <- sample switchoverValue'+ switchoverChecked <- sample switchoverChecked' domElement <- liftIO $ readIORef domElementRef let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement getValue = Input.getValue domInputElement- -- The browser might have messed with the value, or the user could have- -- altered it before activation, so we set it if it isn't what we expect- liftJSM getValue >>= \v0' -> do- when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'+ -- When the value has been updated by setValue before switchover, we must+ -- send an update here to remain in sync. This is because the later+ -- requestDomAction based on the setValue event will not capture events+ -- happening before postBuild, because this code runs after switchover.+ when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue+ -- The user could have altered the value before switchover. This must be+ -- triggered after the setValue one in order for the events to be in the+ -- correct order.+ liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue -- Watch for user interaction and trigger event accordingly requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input) for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->@@ -936,7 +998,17 @@ ] liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'- Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg+ -- When the checked state has been updated by setChecked before+ -- switchover, we must send an update here to remain in sync. This is+ -- because the later requestDomAction based on the setChecked event will not+ -- capture events happening before postBuild, because this code runs after+ -- switchover.+ when (c0 /= switchoverChecked) $ liftIO $ triggerCheckedChangedBySetChecked switchoverChecked+ -- The user could have clicked the checkbox before switchover, we only+ -- detect cases where they flipped the state. This must be triggered after+ -- the setValue one in order for the events to be in the correct order.+ liftJSM (Input.getChecked domInputElement) >>= \realChecked -> when (realChecked /= switchoverChecked) $+ liftIO $ triggerCheckedChangedByUI realChecked _ <- liftJSM $ domInputElement `on` Events.click $ do liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->@@ -949,7 +1021,7 @@ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles return ()- checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost+ checked' <- holdDyn c0 $ leftmost [ checkedChangedBySetChecked , checkedChangedByUI ]@@ -975,8 +1047,7 @@ {-# INLINE textAreaElementImmediate #-} textAreaElementImmediate :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec- , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m- , MonadRef m, Ref m ~ IORef )+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m) => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t) textAreaElementImmediate cfg = do (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()@@ -1021,14 +1092,21 @@ doc <- askDocument -- Expected initial value from config let v0 = _textAreaElementConfig_initialValue cfg- addHydrationStep $ do+ valueAtSwitchover = maybe (pure $ pure v0) (hold v0) (_textAreaElementConfig_setValue cfg)+ addHydrationStepWithSetup valueAtSwitchover $ \switchoverValue' -> do+ switchoverValue <- sample switchoverValue' domElement <- liftIO $ readIORef domElementRef let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement getValue = TextArea.getValue domTextAreaElement- -- The browser might have messed with the value, or the user could have- -- altered it before activation, so we set it if it isn't what we expect- liftJSM getValue >>= \v0' -> do- when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'+ -- When the value has been updated by setValue before switchover, we must+ -- send an update here to remain in sync. This is because the later+ -- requestDomAction based on the setValue event will not capture events+ -- happening before postBuild, because this code runs after switchover.+ when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue+ -- The user could have altered the value before switchover. This must be+ -- triggered after the setValue one in order for the events to be in the+ -- correct order.+ liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue -- Watch for user interaction and trigger event accordingly requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input) for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->@@ -1168,7 +1246,7 @@ {-# INLINE textNodeInternal #-} textNodeInternal- :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)+ :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m) => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t) textNodeInternal tc@(TextNodeConfig !t mSetContents) = do doc <- askDocument@@ -1236,7 +1314,7 @@ {-# INLINE commentNodeInternal #-} commentNodeInternal- :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m, MonadHold t m, MonadSample t m)+ :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Adjustable t m, MonadHold t m) => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t) commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do doc <- askDocument@@ -1275,10 +1353,10 @@ -- out at hydration time, replacing them with empty text nodes. {-# INLINABLE skipToAndReplaceComment #-} skipToAndReplaceComment- :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)+ :: (MonadJSM m, MonadFix m, Adjustable t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Text- -> IORef Text- -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)+ -> IORef (Maybe Text)+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text)) skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case HydrationMode_Immediate -> do -- If we're in immediate mode, we don't try to replace an existing comment,@@ -1286,43 +1364,50 @@ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing append $ toNode t textNodeRef <- liftIO $ newIORef t- keyRef <- liftIO $ newIORef ""+ keyRef <- liftIO $ newIORef Nothing pure (pure (), textNodeRef, keyRef) HydrationMode_Hydrating -> do doc <- askDocument textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized" keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"- let go key0 mLastNode = do- parent <- askParent- node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode- DOM.castTo DOM.Comment node >>= \case+ let+ go Nothing _ = do+ tn <- createTextNode doc ("" :: Text)+ insertAfterPreviousNode tn+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }+ pure (tn, Nothing)+ go (Just key0) mLastNode = do+ parent <- askParent+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case+ Nothing -> go Nothing Nothing+ Just node -> DOM.castTo DOM.Comment node >>= \case Just comment -> do- commentText <- Node.getTextContentUnchecked comment- case T.stripPrefix (prefix <> key0) commentText of+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment+ case T.stripPrefix (prefix <> key0) commentText of -- 'key0' may be @""@ in which case we're just finding the actual key; TODO: Don't be clever. Just key -> do -- Replace the comment with an (invisible) text node tn <- createTextNode doc ("" :: Text) Node.replaceChild_ parent tn comment- pure (tn, key)+ pure (tn, Just key) Nothing -> do- go key0 (Just node)+ go (Just key0) (Just node) Nothing -> do- go key0 (Just node)- switchComment = do- key0 <- liftIO $ readIORef key0Ref- (tn, key) <- go key0 =<< getPreviousNode- setPreviousNode $ Just $ toNode tn- liftIO $ do- writeIORef textNodeRef tn- writeIORef keyRef key+ go (Just key0) (Just node)+ switchComment = do+ key0 <- liftIO $ readIORef key0Ref+ (tn, key) <- go key0 =<< getPreviousNode+ setPreviousNode $ Just $ toNode tn+ liftIO $ do+ writeIORef textNodeRef tn+ writeIORef keyRef key pure (switchComment, textNodeRef, keyRef) {-# INLINABLE skipToReplaceStart #-}-skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)-skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")+skipToReplaceStart :: (MonadJSM m, MonadFix m, Adjustable t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work. {-# INLINABLE skipToReplaceEnd #-}-skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)+skipToReplaceEnd :: (MonadJSM m, MonadFix m, Adjustable t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef (Maybe Text) -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text) skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where@@ -1452,7 +1537,7 @@ traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m -instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Adjustable t (HydrationDomBuilderT s t m) where+instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Adjustable t (HydrationDomBuilderT s t m) where {-# INLINABLE runWithReplace #-} runWithReplace a0 a' = do initialEnv <- HydrationDomBuilderT ask@@ -1614,7 +1699,7 @@ {-# INLINABLE traverseDMapWithKeyWithAdjust' #-} traverseDMapWithKeyWithAdjust'- :: 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)+ :: forall s t m (k :: Type -> Type) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a)) -> DMap k v -> Event t (PatchDMap k v)@@ -1660,7 +1745,7 @@ {-# INLINABLE traverseIntMapWithKeyWithAdjust' #-} traverseIntMapWithKeyWithAdjust'- :: forall s t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)+ :: forall s t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => (IntMap.Key -> v -> HydrationDomBuilderT s t m v') -> IntMap v -> Event t (PatchIntMap v)@@ -1722,7 +1807,7 @@ | ChildReadyState_Unready !(Maybe a) deriving (Show, Read, Eq, Ord) -insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()+insertAfterPreviousNode :: MonadJSM m => DOM.IsNode node => node -> HydrationRunnerT t m () insertAfterPreviousNode node = do parent <- askParent nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode@@ -1734,14 +1819,9 @@ :: ( Adjustable t m , MonadHold t m- , DMap.GCompare k- , MonadIO m+ , GCompare k , MonadJSM m- , PrimMonad m , MonadFix m- , Patch (p k v)- , Patch (p k (Constant Int))- , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int) , Patch (p k (Compose (TraverseChild t m (Some k)) v')) , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v') , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))@@ -1818,14 +1898,14 @@ getHydrationMode >>= \case HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children- phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm+ phs <- sequenceA $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm liftIO $ writeIORef placeholders $! phs insertAfterPreviousNode lastPlaceholder HydrationMode_Immediate -> do let activate i = do append $ toNode $ _traverseChildImmediate_fragment i pure $ _traverseChildImmediate_placeholder i- phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0+ phs <- sequenceA $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0 liftIO $ writeIORef placeholders $! phs append $ toNode lastPlaceholder requestDomAction_ $ ffor children' $ \p -> do@@ -1845,12 +1925,9 @@ , MonadHold t m , MonadJSM m , MonadFix m- , PrimMonad m , Monoid (p (TraverseChild t m Int v')) , Functor p- , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ()) , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')- , Patch (p (HydrationRunnerT t m ())) , Patch (p (TraverseChild t m Int v')) , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document )@@ -2003,7 +2080,7 @@ } deriving Functor {-# INLINABLE drawChildUpdate #-}-drawChildUpdate :: (MonadJSM m, Reflex t)+drawChildUpdate :: MonadJSM m => HydrationDomBuilderEnv t m -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready -> HydrationDomBuilderT s t m (f a)@@ -2065,7 +2142,7 @@ #-} {-# INLINABLE drawChildUpdateInt #-}-drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)+drawChildUpdateInt :: MonadJSM m => HydrationDomBuilderEnv t m -> (IORef (ChildReadyState k) -> JSM ()) -> HydrationDomBuilderT s t m v@@ -2131,10 +2208,6 @@ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-} newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f -instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where- type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m- askJSContext = lift askJSContext- instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where type Ref (HydrationDomBuilderT s t m) = Ref m {-# INLINABLE newRef #-}@@ -2148,10 +2221,6 @@ {-# INLINABLE atomicModifyRef #-} atomicModifyRef r = lift . atomicModifyRef r -instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where- type JSX (HydrationDomBuilderT s t m) = JSX m- liftJS = lift . liftJS- type family EventType en where EventType 'AbortTag = UIEvent EventType 'BlurTag = FocusEvent@@ -2239,7 +2308,7 @@ Beforecopy -> return () Copy -> return () Beforepaste -> return ()- Paste -> return ()+ Paste -> getPasteData Reset -> return () Search -> return () Selectstart -> return ()@@ -2248,7 +2317,7 @@ Touchend -> getTouchEvent Touchcancel -> getTouchEvent Mousewheel -> return ()- Wheel -> return ()+ Wheel -> getWheelEvent {-# INLINABLE defaultDomWindowEventHandler #-} defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))@@ -2289,7 +2358,7 @@ Beforecopy -> return () Copy -> return () Beforepaste -> return ()- Paste -> return ()+ Paste -> getPasteData Reset -> return () Search -> return () Selectstart -> return ()@@ -2298,7 +2367,7 @@ Touchend -> getTouchEvent Touchcancel -> getTouchEvent Mousewheel -> return ()- Wheel -> return ()+ Wheel -> getWheelEvent {-# INLINABLE withIsEvent #-} withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r@@ -2566,6 +2635,15 @@ e <- event bisequence (getClientX e, getClientY e) +{-# INLINABLE getPasteData #-}+getPasteData :: EventM e ClipboardEvent (Maybe Text)+getPasteData = do+ e <- event+ mdt <- ClipboardEvent.getClipboardData e+ case mdt of+ Nothing -> return Nothing+ Just dt -> Just <$> DataTransfer.getData dt ("text" :: Text)+ {-# INLINABLE getTouchEvent #-} getTouchEvent :: EventM e TouchEvent TouchEventResult getTouchEvent = do@@ -2605,6 +2683,26 @@ , _touchEventResult_shiftKey = shiftKey , _touchEventResult_targetTouches = targetTouches , _touchEventResult_touches = touches+ }++{-# INLINABLE getWheelEvent #-}+getWheelEvent :: EventM e WheelEvent WheelEventResult+getWheelEvent = do+ e <- event+ dx :: Double <- WheelEvent.getDeltaX e+ dy :: Double <- WheelEvent.getDeltaY e+ dz :: Double <- WheelEvent.getDeltaZ e+ deltaMode :: Word <- WheelEvent.getDeltaMode e+ return $ WheelEventResult+ { _wheelEventResult_deltaX = dx+ , _wheelEventResult_deltaY = dy+ , _wheelEventResult_deltaZ = dz+ , _wheelEventResult_deltaMode = case deltaMode of+ 0 -> DeltaPixel+ 1 -> DeltaLine+ 2 -> DeltaPage+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode+ _ -> error "getWheelEvent: impossible encoding" } instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
src/Reflex/Dom/Builder/InputDisabled.hs view
@@ -15,13 +15,11 @@ import Control.Monad.Trans.Control import Data.Coerce import qualified Data.Map as Map-import Foreign.JavaScript.TH #ifndef ghcjs_HOST_OS import GHCJS.DOM.Types (MonadJSM (..)) #endif import Reflex import Reflex.Dom.Builder.Class-import Reflex.Dom.Builder.Immediate (HasDocument (..)) import Reflex.Host.Class -- | A DomBuilder transformer that disables all 'inputElement's,@@ -101,14 +99,6 @@ lift $ selectElement cfg' $ runInputDisabledT child instance HasDocument m => HasDocument (InputDisabledT m)--instance HasJSContext m => HasJSContext (InputDisabledT m) where- type JSContextPhantom (InputDisabledT m) = JSContextPhantom m- askJSContext = lift askJSContext--instance HasJS js m => HasJS js (InputDisabledT m) where- type JSX (InputDisabledT m) = JSX m- liftJS = lift . liftJS instance DomRenderHook t m => DomRenderHook t (InputDisabledT m) where withRenderHook f = InputDisabledT . withRenderHook f . runInputDisabledT
src/Reflex/Dom/Builder/Static.hs view
@@ -18,8 +18,9 @@ import Data.IORef (IORef) import Blaze.ByteString.Builder.Html.Utf8 import Control.Lens hiding (element)+import Control.Monad import Control.Monad.Exception-import Control.Monad.Identity+import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Ref import Control.Monad.State.Strict@@ -37,7 +38,8 @@ import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Map.Misc (applyMap)-import Data.Monoid ((<>))+import Data.Maybe (fromMaybe)+import Data.Kind (Type) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T@@ -55,7 +57,6 @@ import Reflex.PostBuild.Base import Reflex.PostBuild.Class import Reflex.TriggerEvent.Class-import System.Random (randomRIO) data StaticDomBuilderEnv t = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool@@ -64,6 +65,7 @@ -- We use this to add a "selected" attribute to the appropriate "option" child element. -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing. -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.+ , _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int } newtype StaticDomBuilderT t m a = StaticDomBuilderT@@ -143,7 +145,7 @@ -- | Static documents don't process events, so all handlers are equivalent data StaticDomHandler (a :: k) (b :: k) = StaticDomHandler -data StaticEventSpec (er :: EventTag -> *) = StaticEventSpec deriving (Generic)+data StaticEventSpec (er :: EventTag -> Type) = StaticEventSpec deriving (Generic) instance Default (StaticEventSpec er) @@ -164,7 +166,7 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where runWithReplace a0 a' = do e <- StaticDomBuilderT ask- key <- replaceStart+ key <- replaceStart e (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a') o <- hold (snd result0) $ fmapCheap snd result' StaticDomBuilderT $ modify $ (:) $ join o@@ -174,10 +176,9 @@ traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove --- TODO remove this?-replaceStart :: (DomBuilder t m, MonadIO m) => m Text-replaceStart = do- str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')+replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text+replaceStart env = do+ str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k)) let key = "-" <> T.pack str _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key } pure key@@ -188,11 +189,9 @@ hoistIntMapWithKeyWithAdjust :: forall t m p a b. ( Adjustable t m , MonadHold t m- , Patch (p a) , Functor p , Patch (p (Behavior t Builder)) , PatchTarget (p (Behavior t Builder)) ~ IntMap (Behavior t Builder)- , Ref m ~ IORef, MonadIO m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m -- TODO remove ) => (forall x. (IntMap.Key -> a -> m x) -> IntMap a@@ -219,12 +218,11 @@ sample o return (result0, result') -hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.+hoistDMapWithKeyWithAdjust :: forall (k :: Type -> Type) v v' t m p. ( Adjustable t m , MonadHold t m , PatchTarget (p k (Constant (Behavior t Builder))) ~ DMap k (Constant (Behavior t Builder)) , Patch (p k (Constant (Behavior t Builder)))- , Ref m ~ IORef, MonadIO m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m -- TODO remove ) => (forall vv vv'. (forall a. k a -> vv a -> m (vv' a))@@ -274,7 +272,7 @@ --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8- modify . (:) =<< (\c -> "<!--" <> c <> "-->") <$> case mSetContents of+ (modify . (:)) . (\c -> "<!--" <> c <> "-->") =<< case mSetContents of Nothing -> return (pure (escape initialContents)) Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on return $ CommentNode ()@@ -287,7 +285,8 @@ es <- newFanEventWithTrigger $ \_ _ -> return (return ()) StaticDomBuilderT $ do let shouldEscape = elementTag `Set.notMember` noEscapeElements- (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes) selectValue <- asks _staticDomBuilderEnv_selectValue let addSelectedAttr attrs sel = case Map.lookup "value" attrs of@@ -311,13 +310,32 @@ return (e, result) {-# INLINABLE inputElement #-} inputElement cfg = do- (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()- let v0 = constDyn $ cfg ^. inputElementConfig_initialValue- let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked+ -- Tweak the config to update the "value" and "checked" attributes appropriately.+ -- TODO: warn upon overwriting values.+ let setInitialValue = Map.insert "value" (_inputElementConfig_initialValue cfg)+ setUpdatedValue updatedAttrs = case _inputElementConfig_setValue cfg of+ Nothing -> updatedAttrs+ Just e -> (Map.singleton "value" . Just <$> e) <> updatedAttrs+ setInitialChecked = case _inputElementConfig_initialChecked cfg of+ True -> Map.insert "checked" "checked"+ False -> id+ setUpdatedChecked updatedAttrs = case _inputElementConfig_setChecked cfg of+ Nothing -> updatedAttrs+ Just e -> (Map.singleton "checked" (Just "checked") <$ e) <> updatedAttrs+ adjustedConfig = _inputElementConfig_elementConfig cfg+ & elementConfig_initialAttributes %~ setInitialValue . setInitialChecked+ & elementConfig_modifyAttributes %~ setUpdatedValue . setUpdatedChecked+ (e, _result) <- element "input" adjustedConfig $ return ()+ v <- case _inputElementConfig_setValue cfg of+ Nothing -> pure $ constDyn (cfg ^. inputElementConfig_initialValue)+ Just ev -> holdDyn (cfg ^. inputElementConfig_initialValue) ev+ c <- case _inputElementConfig_setChecked cfg of+ Nothing -> pure $ constDyn $ _inputElementConfig_initialChecked cfg+ Just ev -> holdDyn (_inputElementConfig_initialChecked cfg) ev let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes return $ InputElement- { _inputElement_value = v0- , _inputElement_checked = c0+ { _inputElement_value = v+ , _inputElement_checked = c , _inputElement_checkedChange = never , _inputElement_input = never , _inputElement_hasFocus = hasFocus@@ -327,12 +345,17 @@ } {-# INLINABLE textAreaElement #-} textAreaElement cfg = do- --TODO: Support setValue event- (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()- let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue+ (e, _domElement) <- element "textarea" (_textAreaElementConfig_elementConfig cfg) $ do+ -- Set the initial value+ void $ textNode $ def+ & textNodeConfig_initialContents .~ _textAreaElementConfig_initialValue cfg+ & textNodeConfig_setContents .~ fromMaybe never (_textAreaElementConfig_setValue cfg)+ v <- case _textAreaElementConfig_setValue cfg of+ Nothing -> pure $ constDyn (cfg ^. textAreaElementConfig_initialValue)+ Just ev -> holdDyn (cfg ^. textAreaElementConfig_initialValue) ev let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes return $ TextAreaElement- { _textAreaElement_value = v0+ { _textAreaElement_value = v , _textAreaElement_input = never , _textAreaElement_hasFocus = hasFocus , _textAreaElement_element = e@@ -341,7 +364,9 @@ selectElement cfg child = do v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue) (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do- (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)+ (a, innerHtml) <- StaticDomBuilderT $ do+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey+ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey StaticDomBuilderT $ lift $ modify $ (:) innerHtml return a let wrapped = SelectElement@@ -363,7 +388,8 @@ renderStatic w = do runDomHost $ do (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef- let env0 = StaticDomBuilderEnv True Nothing+ nextRunWithReplaceKey <- newRef 0+ let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0 mPostBuildTrigger <- readRef postBuildTriggerRef forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
src/Reflex/Dom/Class.hs view
@@ -4,8 +4,7 @@ , module Web.KeyCode ) where -import Data.Map (Map)-import qualified Data.Map as Map+import Control.Lens import Reflex.Class import Web.KeyCode @@ -13,11 +12,9 @@ import Reflex.PerformEvent.Class import Reflex.PostBuild.Class -import Prelude hiding (concat, mapM, mapM_, sequence)---- | Alias for Data.Map.singleton-(=:) :: k -> a -> Map k a-(=:) = Map.singleton+-- | Previously an alias for 'Data.Map.singleton', but now generalised to 'At'+(=:) :: (At m, Monoid m) => Index m -> IxValue m -> m+k =: a = at k ?~ a $ mempty infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6 {-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
src/Reflex/Dom/Location.hs view
@@ -13,10 +13,12 @@ , getLocationUrl , manageHistory , manageHistory'+ , manageHistoryExposingExternalUpdates , HistoryCommand (..) , HistoryStateUpdate (..) , HistoryItem (..) , getLocationUri+ , popHistoryState ) where import Reflex@@ -26,7 +28,6 @@ import Control.Monad ((>=>)) import Control.Monad.Fix (MonadFix) import Data.Align (align)-import Data.Monoid import Data.Text (Text) import Data.These (These(..)) import qualified GHCJS.DOM as DOM@@ -170,7 +171,15 @@ -- ^ Don't do anything until this event has fired -> Event t HistoryCommand -> m (Dynamic t HistoryItem)-manageHistory' switchover runCmd = do+manageHistory' switchover runCmd = fst <$> manageHistoryExposingExternalUpdates switchover runCmd++manageHistoryExposingExternalUpdates+ :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))+ => Event t ()+ -- ^ Don't do anything until this event has fired+ -> Event t HistoryCommand+ -> m (Dynamic t HistoryItem, Event t HistoryItem)+manageHistoryExposingExternalUpdates switchover runCmd = do window <- DOM.currentWindowUnchecked location <- Window.getLocation window history <- Window.getHistory window@@ -196,5 +205,16 @@ itemSetInternal <- performEvent $ ffor itemSetInternal' $ \cmd -> liftJSM $ do runHistoryCommand history cmd getCurrentHistoryItem- holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]+ currentHistoryItem <- holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]+ pure (currentHistoryItem, itemSetExternal) --TODO: Handle title setting better++popHistoryState+ :: (PerformEvent t m, MonadJSM (Performable m))+ => Event t ()+ -> m ()+popHistoryState evt =+ performEvent_ $ ffor evt $ \_ -> do+ window <- DOM.currentWindowUnchecked+ history <- Window.getHistory window+ History.back history
src/Reflex/Dom/Main.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -34,14 +33,13 @@ import Control.Concurrent import Control.Lens import Control.Monad-import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)+import Control.Monad.Reader import Control.Monad.Ref import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum (..)) import Data.Foldable (for_) import Data.IORef import Data.Maybe-import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding@@ -59,7 +57,7 @@ {-# INLINE mainHydrationWidgetWithHead #-} mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()-mainHydrationWidgetWithHead = mainHydrationWidgetWithHead'+mainHydrationWidgetWithHead head' body = mainHydrationWidgetWithHead' head' body {-# INLINABLE mainHydrationWidgetWithHead' #-} -- | Warning: `mainHydrationWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.@@ -68,13 +66,19 @@ {-# INLINE mainHydrationWidgetWithSwitchoverAction #-} mainHydrationWidgetWithSwitchoverAction :: JSM () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()-mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverAction'+mainHydrationWidgetWithSwitchoverAction switchoverAction head' body = mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body {-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-} -- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases. mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()-mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do- runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do+mainHydrationWidgetWithSwitchoverAction' = mainHydrationWidgetWithSwitchoverActionWithFailure' (pure ())+++{-# INLINABLE mainHydrationWidgetWithSwitchoverActionWithFailure' #-}+-- | Warning: `mainHydrationWidgetWithSwitchoverActionWithFaiilure'` is provided only as performance tweak. It is expected to disappear in future releases.+mainHydrationWidgetWithSwitchoverActionWithFailure' :: IO () -> JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()+mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchoverAction head' body = do+ runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction $ \appendHead appendBody -> do appendHead head' appendBody body @@ -89,7 +93,21 @@ -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ()))) ) -> IO (a, FireCommand DomTimeline DomHost)-attachHydrationWidget switchoverAction jsSing w = do+attachHydrationWidget = attachHydrationWidgetWithFailure (pure ())++{-# INLINABLE attachHydrationWidgetWithFailure #-}+attachHydrationWidgetWithFailure+ :: IO ()+ -> JSM ()+ -> JSContextSingleton ()+ -> ( Event DomTimeline ()+ -> IORef HydrationMode+ -> Maybe (IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())])+ -> EventChannel+ -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))+ )+ -> IO (a, FireCommand DomTimeline DomHost)+attachHydrationWidgetWithFailure onFailure switchoverAction jsSing w = do hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating rootNodesRef <- liftIO $ newIORef [] events <- newChan@@ -105,7 +123,7 @@ rootNodes <- liftIO $ readIORef rootNodesRef let delayedAction = do for_ (reverse rootNodes) $ \(rootNode, runner) -> do- let hydrate = runHydrationRunnerT runner Nothing rootNode events+ let hydrate = runHydrationRunnerTWithFailure runner onFailure Nothing rootNode events void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing liftIO $ writeIORef hydrationMode HydrationMode_Immediate runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing@@ -126,11 +144,22 @@ -> FloatingWidget () () ) -> JSM ()-runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do+runHydrationWidgetWithHeadAndBody = runHydrationWidgetWithHeadAndBodyWithFailure (pure ())++{-# INLINABLE runHydrationWidgetWithHeadAndBodyWithFailure #-}+runHydrationWidgetWithHeadAndBodyWithFailure+ :: IO ()+ -> JSM ()+ -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head" --TODO: test invoking this more than once+ -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body" --TODO: test invoking this more than once+ -> FloatingWidget () ()+ )+ -> JSM ()+runHydrationWidgetWithHeadAndBodyWithFailure onFailure switchoverAction app = withJSContextSingletonMono $ \jsSing -> do globalDoc <- currentDocumentUnchecked headElement <- getHeadUnchecked globalDoc bodyElement <- getBodyUnchecked globalDoc- (events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do+ (events, fc) <- liftIO . attachHydrationWidgetWithFailure onFailure switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c hydrateDom n w = do@@ -157,7 +186,7 @@ {-# INLINE mainWidget #-} mainWidget :: (forall x. Widget x ()) -> JSM ()-mainWidget = mainWidget'+mainWidget w = mainWidget' w {-# INLINABLE mainWidget' #-} -- | Warning: `mainWidget'` is provided only as performance tweak. It is expected to disappear in future releases.
src/Reflex/Dom/Old.hs view
@@ -11,6 +11,7 @@ #ifdef USE_TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} #endif+{-# LANGUAGE TypeOperators #-} module Reflex.Dom.Old ( MonadWidget , El@@ -63,7 +64,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)-import Foreign.JavaScript.TH import qualified GHCJS.DOM.Element as Element import GHCJS.DOM.EventM (EventM) import GHCJS.DOM.NamedNodeMap as NNM@@ -118,8 +118,6 @@ , DOM.MonadJSM (Performable m) #endif , TriggerEvent t m- , HasJSContext m- , HasJSContext (Performable m) , HasDocument m , MonadRef m , Ref m ~ Ref IO@@ -267,7 +265,7 @@ & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f snd <$> element elementTag cfg child -elDynHtmlAttr' :: (DOM.MonadJSM m, MonadWidget t m) => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)+elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t) elDynHtmlAttr' elementTag attrs html = do let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs (e, _) <- element elementTag cfg $ return ()
src/Reflex/Dom/Prerender.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -22,14 +23,16 @@ , PrerenderBaseConstraints ) where +import Control.Monad+import Control.Monad.Fix import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader-import Control.Monad.Ref (MonadRef(..))+import Control.Monad.Ref (MonadRef(..), MonadAtomicRef(..)) import Data.IORef (IORef, newIORef)-import Data.Semigroup (Semigroup)+import Data.Kind (Type)+import Data.Semigroup.Commutative import Data.Text (Text) import Data.Void-import Foreign.JavaScript.TH import GHCJS.DOM.Types (MonadJSM) import Reflex hiding (askEvents) import Reflex.Dom.Builder.Class@@ -45,19 +48,17 @@ import qualified GHCJS.DOM.Node as Node import qualified GHCJS.DOM.Types as DOM -type PrerenderClientConstraint js t m =+type PrerenderClientConstraint t m = ( DomBuilder t m , DomBuilderSpace m ~ GhcjsDomSpace , DomRenderHook t m , HasDocument m , TriggerEvent t m- , PrerenderBaseConstraints js t m+ , PrerenderBaseConstraints t m ) -type PrerenderBaseConstraints js t m =- ( HasJSContext (Performable m)- , HasJSContext m- , MonadFix m+type PrerenderBaseConstraints t m =+ ( MonadFix m , MonadHold t m , MonadJSM (Performable m) , MonadJSM m@@ -70,30 +71,28 @@ , PrimMonad m , Ref (Performable m) ~ IORef , Ref m ~ IORef- , HasJS js m- , HasJS js (Performable m) ) -- | Render the first widget on the server, and the second on the client. The -- hydration builder will run *both* widgets. prerender_- :: (Functor m, Reflex t, Prerender js t m)+ :: (Functor m, Prerender t m) => m () -> Client m () -> m () prerender_ server client = void $ prerender server client -class (PrerenderClientConstraint js t (Client m), Client (Client m) ~ Client m, Prerender js t (Client m)) => Prerender js t m | m -> t js where+class (PrerenderClientConstraint t (Client m), Client (Client m) ~ Client m, Prerender t (Client m)) => Prerender t m | m -> t where -- | Monad in which the client widget is built- type Client m :: * -> *+ type Client m :: Type -> Type -- | Render the first widget on the server, and the second on the client. The -- hydration builder will run *both* widgets, updating the result dynamic at -- switchover time. prerender :: m a -> Client m a -> m (Dynamic t a) -instance (ReflexHost t, Adjustable t m, PrerenderBaseConstraints js t m) => Prerender js t (HydrationDomBuilderT GhcjsDomSpace t m) where+instance (ReflexHost t, Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (HydrationDomBuilderT GhcjsDomSpace t m) where type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m prerender _ client = pure <$> client -instance (Adjustable t m, PrerenderBaseConstraints js t m, ReflexHost t) => Prerender js t (HydrationDomBuilderT HydrationDomSpace t m) where+instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT HydrationDomSpace t m) where -- | PostBuildT is needed here because we delay running the client builder -- until after switchover, at which point the postBuild of @m@ has already fired type Client (HydrationDomBuilderT HydrationDomSpace t m) = PostBuildT t (HydrationDomBuilderT GhcjsDomSpace t m)@@ -132,14 +131,14 @@ insertBefore df =<< deleteToPrerenderEnd doc holdDyn a0 a' -newtype UnrunnableT js t m a = UnrunnableT (ReaderT Void m a)+newtype UnrunnableT t m a = UnrunnableT (ReaderT Void m a) deriving (Functor, Applicative, Monad, MonadTrans) -unrunnable :: UnrunnableT js t m a+unrunnable :: UnrunnableT t m a unrunnable = UnrunnableT $ ReaderT $ \case {} -instance (Reflex t, Monad m) => DomBuilder t (UnrunnableT js t m) where- type DomBuilderSpace (UnrunnableT js t m) = GhcjsDomSpace+instance (Reflex t, Monad m) => DomBuilder t (UnrunnableT t m) where+ type DomBuilderSpace (UnrunnableT t m) = GhcjsDomSpace textNode _ = unrunnable commentNode _ = unrunnable element _ _ _ = unrunnable@@ -148,103 +147,79 @@ selectElement _ _ = unrunnable placeRawElement _ = unrunnable wrapRawElement _ _ = unrunnable-instance (Reflex t, Monad m) => NotReady t (UnrunnableT js t m) where+instance (Reflex t, Monad m) => NotReady t (UnrunnableT t m) where notReadyUntil _ = unrunnable notReady = unrunnable-instance (Reflex t, Monad m) => Adjustable t (UnrunnableT js t m) where+instance (Reflex t, Monad m) => Adjustable t (UnrunnableT t m) where runWithReplace _ _ = unrunnable traverseIntMapWithKeyWithAdjust _ _ _ = unrunnable traverseDMapWithKeyWithAdjust _ _ _ = unrunnable traverseDMapWithKeyWithAdjustWithMove _ _ _ = unrunnable-instance (Reflex t, Monad m) => PerformEvent t (UnrunnableT js t m) where- type Performable (UnrunnableT js t m) = UnrunnableT js t m+instance (Reflex t, Monad m) => PerformEvent t (UnrunnableT t m) where+ type Performable (UnrunnableT t m) = UnrunnableT t m performEvent _ = unrunnable performEvent_ _ = unrunnable-instance Monad m => MonadRef (UnrunnableT js t m) where- type Ref (UnrunnableT js t m) = Ref IO+instance Monad m => MonadRef (UnrunnableT t m) where+ type Ref (UnrunnableT t m) = Ref IO newRef _ = unrunnable readRef _ = unrunnable writeRef _ _ = unrunnable-instance Monad m => HasDocument (UnrunnableT js t m) where+instance Monad m => MonadAtomicRef (UnrunnableT t m) where+ atomicModifyRef _ _ = unrunnable+instance Monad m => HasDocument (UnrunnableT t m) where askDocument = unrunnable-instance Monad m => HasJSContext (UnrunnableT js t m) where- type JSContextPhantom (UnrunnableT js t m) = ()- askJSContext = unrunnable-instance Monad m => HasJS JS' (UnrunnableT js t m) where- type JSX (UnrunnableT js t m) = UnrunnableT js t m- liftJS _ = unrunnable-instance Monad m => MonadJS JS' (UnrunnableT js t m) where- runJS _ _ = unrunnable- forkJS _ = unrunnable- mkJSUndefined = unrunnable- isJSNull _ = unrunnable- isJSUndefined _ = unrunnable- fromJSBool _ = unrunnable- fromJSString _ = unrunnable- fromJSArray _ = unrunnable- fromJSUint8Array _ = unrunnable- fromJSNumber _ = unrunnable- withJSBool _ _ = unrunnable- withJSString _ _ = unrunnable- withJSNumber _ _ = unrunnable- withJSArray _ _ = unrunnable- withJSUint8Array _ _ = unrunnable- mkJSFun _ = unrunnable- freeJSFun _ = unrunnable- setJSProp _ _ _ = unrunnable- getJSProp _ _ = unrunnable- withJSNode _ _ = unrunnable-instance Monad m => TriggerEvent t (UnrunnableT js t m) where+instance Monad m => TriggerEvent t (UnrunnableT t m) where newTriggerEvent = unrunnable newTriggerEventWithOnComplete = unrunnable newEventWithLazyTriggerWithOnComplete _ = unrunnable-instance Monad m => MonadReflexCreateTrigger t (UnrunnableT js t m) where+instance Monad m => MonadReflexCreateTrigger t (UnrunnableT t m) where newEventWithTrigger _ = unrunnable newFanEventWithTrigger _ = unrunnable-instance Monad m => MonadFix (UnrunnableT js t m) where+instance Monad m => MonadFix (UnrunnableT t m) where mfix _ = unrunnable-instance Monad m => MonadHold t (UnrunnableT js t m) where+instance (Monad m, MonadHold t m) => MonadHold t (UnrunnableT t m) where hold _ _ = unrunnable holdDyn _ _ = unrunnable holdIncremental _ _ = unrunnable buildDynamic _ _ = unrunnable headE _ = unrunnable-instance Monad m => MonadSample t (UnrunnableT js t m) where+ now = unrunnable+instance Monad m => MonadSample t (UnrunnableT t m) where sample _ = unrunnable-instance Monad m => MonadIO (UnrunnableT js t m) where+instance Monad m => MonadIO (UnrunnableT t m) where liftIO _ = unrunnable #ifndef ghcjs_HOST_OS-instance Monad m => MonadJSM (UnrunnableT js t m) where+instance Monad m => MonadJSM (UnrunnableT t m) where liftJSM' _ = unrunnable #endif-instance (Reflex t, Monad m) => PostBuild t (UnrunnableT js t m) where+instance (Reflex t, Monad m) => PostBuild t (UnrunnableT t m) where getPostBuild = unrunnable-instance Monad m => PrimMonad (UnrunnableT js t m) where- type PrimState (UnrunnableT js t m) = PrimState IO+instance Monad m => PrimMonad (UnrunnableT t m) where+ type PrimState (UnrunnableT t m) = PrimState IO primitive _ = unrunnable-instance (Reflex t, Monad m) => DomRenderHook t (UnrunnableT js t m) where+instance (Reflex t, Monad m) => DomRenderHook t (UnrunnableT t m) where withRenderHook _ _ = unrunnable requestDomAction _ = unrunnable requestDomAction_ _ = unrunnable-instance (Reflex t, Monad m) => Prerender JS' t (UnrunnableT js t m) where- type Client (UnrunnableT js t m) = UnrunnableT js t m+instance (Reflex t, Monad m, MonadHold t m) => Prerender t (UnrunnableT t m) where+ type Client (UnrunnableT t m) = UnrunnableT t m prerender _ _ = unrunnable -instance (SupportsStaticDomBuilder t m) => Prerender JS' t (StaticDomBuilderT t m) where- type Client (StaticDomBuilderT t m) = UnrunnableT JS' t m+instance (SupportsStaticDomBuilder t m) => Prerender t (StaticDomBuilderT t m) where+ type Client (StaticDomBuilderT t m) = UnrunnableT t m prerender server _ = do _ <- commentNode $ CommentNodeConfig startMarker Nothing a <- server _ <- commentNode $ CommentNodeConfig endMarker Nothing pure $ pure a -instance (Prerender js t m, Monad m) => Prerender js t (ReaderT r m) where+instance (Prerender t m, Monad m) => Prerender t (ReaderT r m) where type Client (ReaderT r m) = ReaderT r (Client m) prerender server client = do r <- ask lift $ prerender (runReaderT server r) (runReaderT client r) -instance (Prerender js t m, Monad m, Reflex t, MonadFix m, Monoid w) => Prerender js t (DynamicWriterT t w m) where+instance (Prerender t m, Monad m, MonadFix m, Reflex t, Monoid w) => Prerender t (DynamicWriterT t w m) where type Client (DynamicWriterT t w m) = DynamicWriterT t w (Client m) prerender server client = do x <- lift $ prerender (runDynamicWriterT server) (runDynamicWriterT client)@@ -253,7 +228,7 @@ tellDyn w pure a -instance (Prerender js t m, Monad m, Reflex t, Semigroup w) => Prerender js t (EventWriterT t w m) where+instance (Prerender t m, Monad m, Reflex t, Semigroup w) => Prerender t (EventWriterT t w m) where type Client (EventWriterT t w m) = EventWriterT t w (Client m) prerender server client = do x <- lift $ prerender (runEventWriterT server) (runEventWriterT client)@@ -262,7 +237,7 @@ tellEvent w pure a -instance (Prerender js t m, MonadFix m, Reflex t) => Prerender js t (RequesterT t request response m) where+instance (Prerender t m, MonadFix m, Reflex t) => Prerender t (RequesterT t request response m) where type Client (RequesterT t request response m) = RequesterT t request response (Client m) prerender server client = mdo let fannedResponses = fanInt responses@@ -274,7 +249,7 @@ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requestsDyn return result -instance (Prerender js t m, Monad m, Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q) => Prerender js t (QueryT t q m) where+instance (Prerender t m, Monad m, Reflex t, MonadFix m, Group q, Commutative q, Query q, Eq q) => Prerender t (QueryT t q m) where type Client (QueryT t q m) = QueryT t q (Client m) prerender server client = mdo result <- queryDyn query@@ -283,15 +258,15 @@ query = incrementalToDynamic =<< inc -- Can we avoid the incrementalToDynamic? pure a -instance (Prerender js t m, Monad m) => Prerender js t (InputDisabledT m) where+instance Prerender t m => Prerender t (InputDisabledT m) where type Client (InputDisabledT m) = InputDisabledT (Client m) prerender (InputDisabledT server) (InputDisabledT client) = InputDisabledT $ prerender server client -instance (Prerender js t m, Monad m) => Prerender js t (HydratableT m) where+instance Prerender t m => Prerender t (HydratableT m) where type Client (HydratableT m) = HydratableT (Client m) prerender (HydratableT server) (HydratableT client) = HydratableT $ prerender server client -instance (Prerender js t m, Monad m, ReflexHost t) => Prerender js t (PostBuildT t m) where+instance (Prerender t m, Monad m, ReflexHost t) => Prerender t (PostBuildT t m) where type Client (PostBuildT t m) = PostBuildT t (Client m) prerender server client = PostBuildT $ do pb <- ask@@ -301,7 +276,7 @@ startMarker = "prerender/start" endMarker = "prerender/end" -deleteToPrerenderEnd :: (MonadIO m, MonadJSM m, Reflex t, MonadFix m) => DOM.Document -> HydrationRunnerT t m DOM.Comment+deleteToPrerenderEnd :: (MonadJSM m, Reflex t, MonadFix m) => DOM.Document -> HydrationRunnerT t m DOM.Comment deleteToPrerenderEnd doc = do startNode <- hydrateComment doc startMarker Nothing let go (n :: Int) lastNode = Node.getNextSibling lastNode >>= \case
src/Reflex/Dom/WebSocket.hs view
@@ -8,7 +8,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -31,7 +30,6 @@ import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span) import Reflex.Class-import Reflex.Dom.Class import Reflex.Dom.WebSocket.Foreign import Reflex.PerformEvent.Class import Reflex.PostBuild.Class@@ -41,9 +39,8 @@ import Control.Concurrent.STM import Control.Exception import Control.Lens-import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)+import Control.Monad hiding (forM, mapM, mapM_, sequence) import Control.Monad.IO.Class-import Control.Monad.State import Data.Aeson import Data.ByteString (ByteString) import Data.ByteString.Lazy (toStrict)@@ -83,12 +80,11 @@ ) } -webSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)+webSocket :: (MonadJSM m, MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t) webSocket url config = webSocket' url config onBSMessage -webSocket' :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> JSM b) -> m (RawWebSocket t b)+webSocket' :: (MonadJSM m, MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> JSM b) -> m (RawWebSocket t b) webSocket' url config onRawMessage = do- wv <- fmap unJSContextSingleton askJSContext (eRecv, onMessage) <- newTriggerEvent currentSocketRef <- liftIO $ newIORef Nothing (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete@@ -106,7 +102,7 @@ liftIO $ threadDelay 1000000 start start = do- ws <- newWebSocket wv url (_webSocketConfig_protocols config) (onRawMessage >=> liftIO . onMessage) (liftIO onOpen) (liftIO onError) onClose+ ws <- newWebSocket url (_webSocketConfig_protocols config) (onRawMessage >=> liftIO . onMessage) (liftIO onOpen) (liftIO onError) onClose liftIO $ writeIORef currentSocketRef $ Just ws return () performEvent_ . (liftJSM start <$) =<< getPostBuild@@ -136,10 +132,10 @@ unless success $ atomically $ unGetTQueue payloadQueue payload return $ RawWebSocket eRecv eOpen eError eClose -textWebSocket :: (IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t Text)+textWebSocket :: (IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m), PostBuild t m, TriggerEvent t m, PerformEvent t m) => Text -> WebSocketConfig t a -> m (RawWebSocket t Text) textWebSocket url cfg = webSocket' url cfg (either (return . decodeUtf8) fromJSValUnchecked) -jsonWebSocket :: (ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))+jsonWebSocket :: (ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m), PostBuild t m, TriggerEvent t m, PerformEvent t m) => Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b)) jsonWebSocket url cfg = do ws <- textWebSocket url $ cfg { _webSocketConfig_send = fmap (decodeUtf8 . toStrict . encode) <$> _webSocketConfig_send cfg } return ws { _webSocket_recv = jsonDecode . textToJSString <$> _webSocket_recv ws }
src/Reflex/Dom/WebSocket/Foreign.hs view
@@ -53,15 +53,14 @@ closeWebSocket (JSWebSocket ws) code reason = DOM.close ws (Just code) (Just reason) newWebSocket- :: a- -> Text -- url+ :: Text -- url -> [Text] -- protocols -> (Either ByteString JSVal -> JSM ()) -- onmessage -> JSM () -- onopen -> JSM () -- onerror -> ((Bool, Word, Text) -> JSM ()) -- onclose -> JSM JSWebSocket-newWebSocket _ url protocols onMessage onOpen onError onClose = do+newWebSocket url protocols onMessage onOpen onError onClose = do let onOpenWrapped = fun $ \_ _ _ -> onOpen onErrorWrapped = fun $ \_ _ _ -> onError onCloseWrapped = fun $ \_ _ (e:_) -> do
src/Reflex/Dom/WebSocket/Query.hs view
@@ -4,15 +4,15 @@ import Data.Default import Control.Monad.Fix+import Data.Semigroup.Commutative import Data.Text (Text) import Data.Aeson import Reflex import Reflex.Dom.WebSocket-import Foreign.JavaScript.TH import Data.Maybe import Language.Javascript.JSaddle.Types (MonadJSM) -runWebSocketQuery :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t, ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q), Additive q, Group q, Eq q)+runWebSocketQuery :: (MonadJSM m, MonadJSM (Performable m), PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, ToJSON q, MonadFix m, Query q, FromJSON (QueryResult q), Commutative q, Group q, Eq q) => QueryT t q m a -> Text -- ^ WebSocket url -> m a@@ -23,7 +23,7 @@ let updatedRequest = leftmost [updated request, tag (current request) postBuild] return a -cropQueryT :: (Reflex t, MonadHold t m, MonadFix m, Query q, Additive q, Group q, Eq q)+cropQueryT :: (Reflex t, MonadHold t m, MonadFix m, Query q, Commutative q, Group q, Eq q) => QueryT t q m a -> Event t (QueryResult q) -> m (a, Dynamic t q)
src/Reflex/Dom/Widget/Basic.hs view
@@ -70,14 +70,12 @@ import Reflex.PostBuild.Class import Reflex.Workflow -import Control.Arrow import Control.Lens hiding (children, element)-import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)+import Control.Monad.Fix import Data.Align import Data.Default-import Data.Either-import Data.Foldable import Data.Functor (void)+import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map as Map import Data.Map.Misc@@ -87,8 +85,6 @@ import Data.Text (Text) import qualified Data.Text as T import Data.These-import Data.Traversable-import Prelude hiding (mapM, mapM_, sequence, sequence_) -- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set. -- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.@@ -138,7 +134,6 @@ display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m () display = dynText . fmap (T.pack . show) -{-# DEPRECATED button "Use 'elAttr'' in combination with 'domEvent' instead" #-} button :: DomBuilder t m => Text -> m (Event t ()) button t = do (e, _) <- element "button" def $ text t@@ -272,25 +267,21 @@ return $ if Map.null p then Nothing else Just p return modificationsNeeded -{-# DEPRECATED Link "Will be removed when 'linkClass' and 'link' are removed. Follow those functions' deprecation instructions." #-} newtype Link t = Link { _link_clicked :: Event t () } -{-# DEPRECATED linkClass "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-} linkClass :: DomBuilder t m => Text -> Text -> m (Link t) linkClass s c = do (l,_) <- elAttr' "a" ("class" =: c) $ text s return $ Link $ domEvent Click l -{-# DEPRECATED link "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-} link :: DomBuilder t m => Text -> m (Link t) link s = linkClass s "" divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a divClass = elClass "div" -{-# DEPRECATED dtdd "Use an application specific widget generating function" #-} dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a dtdd h w = do el "dt" $ text h@@ -301,8 +292,7 @@ -- TODO: Move to an example project. -- | A widget to display a table with static columns and dynamic rows.-{-# DEPRECATED tableDynAttr "Use an application specific widget generating function" #-}-tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)+tableDynAttr :: forall t m r k v. (Ord k, Eq r, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Text -- ^ Class applied to <table> element -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget) -> Dynamic t (Map k r) -- ^ Map from row key to row value@@ -321,7 +311,6 @@ -- | A widget to construct a tabbed view that shows only one of its child widgets at a time. -- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays -- the corresponding child and hides all others.-{-# DEPRECATED tabDisplay "Use an application specific widget generating function" #-} tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k) => Text -- ^ Class applied to <ul> element -> Text -- ^ Class applied to currently active <li> element@@ -348,5 +337,5 @@ return $ fmap (const k) (_link_clicked a) class HasAttributes a where- type Attrs a :: *+ type Attrs a :: Type attributes :: Lens' a (Attrs a)
src/Reflex/Dom/Widget/Input.hs view
@@ -13,12 +13,14 @@ {-# LANGUAGE TemplateHaskell #-} #endif {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where import Prelude import Control.Lens hiding (element, ix)+import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader@@ -27,18 +29,15 @@ import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Functor.Misc+import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T-import qualified GHCJS.DOM.GlobalEventHandlers as Events-import GHCJS.DOM.EventM (on)-import qualified GHCJS.DOM.FileList as FileList import GHCJS.DOM.HTMLInputElement (HTMLInputElement) import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)-import GHCJS.DOM.Types (MonadJSM, File, uncheckedCastTo)+import GHCJS.DOM.Types (File, uncheckedCastTo) import qualified GHCJS.DOM.Types as DOM (HTMLElement(..), EventTarget(..)) import Reflex.Class import Reflex.Collection@@ -48,7 +47,6 @@ import Reflex.Dom.Widget.Basic import Reflex.Dynamic import Reflex.PostBuild.Class-import Reflex.TriggerEvent.Class import qualified Text.Read as T import qualified GHCJS.DOM.Event as Event@@ -235,7 +233,7 @@ , _checkbox_change = _inputElement_checkedChange i } -type family CheckboxViewEventResultType (en :: EventTag) :: * where+type family CheckboxViewEventResultType (en :: EventTag) :: Type where CheckboxViewEventResultType 'ClickTag = Bool CheckboxViewEventResultType t = EventResultType t @@ -292,7 +290,7 @@ -- | Create a view only checkbox {-# INLINABLE checkboxView #-}-checkboxView :: forall t m. (DomBuilder t m, DomBuilderSpace m ~ GhcjsDomSpace, PostBuild t m, MonadHold t m) => Dynamic t (Map Text Text) -> Dynamic t Bool -> m (Event t Bool)+checkboxView :: forall t m. (DomBuilder t m, DomBuilderSpace m ~ GhcjsDomSpace, PostBuild t m) => Dynamic t (Map Text Text) -> Dynamic t Bool -> m (Event t Bool) checkboxView dAttrs dValue = do let permanentAttrs = "type" =: "checkbox" modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.union permanentAttrs) dAttrs@@ -338,7 +336,7 @@ def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty } -fileInput :: forall t m. (MonadIO m, MonadJSM m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)+fileInput :: forall t m. (MonadIO m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace) => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t) fileInput config = do let insertType = Map.insert "type" "file"@@ -371,7 +369,7 @@ , _dropdownConfig_attributes = constDyn mempty } -type family DropdownViewEventResultType (en :: EventTag) :: * where+type family DropdownViewEventResultType (en :: EventTag) :: Type where DropdownViewEventResultType 'ChangeTag = Text DropdownViewEventResultType t = EventResultType t @@ -437,9 +435,12 @@ let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs) modifyAttrs <- dynamicAttributesToModifyAttributes attrs+ postBuild <- getPostBuild+ let setSelection = attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys $+ leftmost [setK, k0 <$ postBuild] let cfg = def & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs- & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)+ & selectElementConfig_setValue .~ fmap (T.pack . show) setSelection (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey elDynAttr "option" optionAttrs $ dynText v@@ -626,9 +627,6 @@ type Attrs (FileInputConfig t) = Dynamic t (Map Text Text) attributes = fileInputConfig_attributes -class HasSetValue a where- type SetValue a :: *- setValue :: Lens' a (SetValue a) instance HasSetValue (TextAreaConfig t) where type SetValue (TextAreaConfig t) = Event t Text@@ -651,7 +649,7 @@ setValue = checkboxConfig_setValue class HasValue a where- type Value a :: *+ type Value a :: Type value :: a -> Value a instance HasValue (InputElement er d t) where
src/Reflex/Dom/Widget/Lazy.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Reflex.Dom.Widget.Lazy where import Reflex.Class@@ -20,14 +21,13 @@ import Data.Fixed import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import GHCJS.DOM.Element import GHCJS.DOM.Types (MonadJSM) -- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.-virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)+virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k, Eq v) => Dynamic t Int -- ^ The height of the visible region in pixels -> Int -- ^ The height of each row in pixels -> Dynamic t Int -- ^ The total number of items@@ -117,7 +117,7 @@ "overflow" =: "hidden" <> "position" =: "relative" mkRow k = toStyleAttr $ "height" =: (T.pack (show rowPx) <> "px") <>- "top" =: ((<>"px") $ T.pack $ show $ keyToIndex k * rowPx) <>+ "top" =: (<> "px") (T.pack $ show $ keyToIndex k * rowPx) <> "position" =: "absolute" <> "width" =: "100%" findWindow sizeIncrement windowSize startingPosition =
src/Reflex/Dom/Widget/Resize.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Reflex.Dom.Widget.Resize where import Reflex.Class@@ -16,12 +17,10 @@ import Reflex.PostBuild.Class import Reflex.TriggerEvent.Class -import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import GHCJS.DOM.Element@@ -37,19 +36,19 @@ -- This function can cause strange scrollbars to appear in some circumstances. -- These can be hidden with pseudo selectors, for example, in webkit browsers: -- .wrapper *::-webkit-scrollbar { width: 0px; background: transparent; }-resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (Maybe Double, Maybe Double), a) resizeDetector = resizeDetectorWithStyle "" resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute. -> m a -- ^ The embedded widget- -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString) resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute. -> m a -- ^ The embedded widget- -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget resizeDetectorWithAttrs attrs w = do let childStyle = "position: absolute; left: 0; top: 0;" containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"@@ -91,4 +90,4 @@ size0 <- performEvent $ fmap (const $ liftJSM reset) pb rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll] dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]- return (fmapMaybe void resize, w')+ return (updated dimensions, w')
src/Reflex/Dom/Xhr.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}@@ -8,6 +7,7 @@ #ifdef USE_TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} #endif+{-# LANGUAGE TypeOperators #-} -- | A module for performing asynchronous HTTP calls from JavaScript -- using the@@ -159,6 +159,8 @@ import Data.Aeson.Encode #endif import qualified Data.ByteString.Lazy as BL+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI import Data.Default import qualified Data.List as L import Data.Map (Map)@@ -171,7 +173,6 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as B import Data.Traversable-import Data.Typeable import Language.Javascript.JSaddle.Monad (JSM, askJSM, runJSM, MonadJSM, liftJSM) @@ -180,7 +181,7 @@ , _xhrRequest_url :: Text , _xhrRequest_config :: XhrRequestConfig a }- deriving (Show, Read, Eq, Ord, Typeable, Functor)+ deriving (Show, Read, Eq, Ord, Functor) data XhrRequestConfig a = XhrRequestConfig { _xhrRequestConfig_headers :: Map Text Text@@ -191,21 +192,20 @@ , _xhrRequestConfig_withCredentials :: Bool , _xhrRequestConfig_responseHeaders :: XhrResponseHeaders }- deriving (Show, Read, Eq, Ord, Typeable, Functor)+ deriving (Show, Read, Eq, Ord, Functor) data XhrResponse = XhrResponse { _xhrResponse_status :: Word , _xhrResponse_statusText :: Text , _xhrResponse_response :: Maybe XhrResponseBody , _xhrResponse_responseText :: Maybe Text- , _xhrResponse_headers :: Map Text Text+ , _xhrResponse_headers :: Map (CI Text) Text }- deriving (Typeable) data XhrResponseHeaders =- OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response+ OnlyHeaders (Set.Set (CI Text)) -- ^ Parse a subset of headers from the XHR Response | AllHeaders -- ^ Parse all headers from the XHR Response- deriving (Show, Read, Eq, Ord, Typeable)+ deriving (Show, Read, Eq, Ord) instance Default XhrResponseHeaders where def = OnlyHeaders mempty@@ -237,7 +237,7 @@ -- the XHR connection), and will pass an exception ('XhrException') to the -- continuation if the connection cannot be made (or is aborted). newXMLHttpRequestWithError- :: (HasJSContext m, MonadJSM m, IsXhrPayload a)+ :: (MonadJSM m, IsXhrPayload a) => XhrRequest a -- ^ The request to make. -> (Either XhrException XhrResponse -> JSM ())@@ -275,7 +275,7 @@ AllHeaders -> parseAllHeadersString <$> xmlHttpRequestGetAllResponseHeaders xhr OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)- (Map.fromSet id xs)+ (Map.fromSet CI.original xs) _ <- liftJSM $ cb $ Right XhrResponse { _xhrResponse_status = status , _xhrResponse_statusText = statusText@@ -288,12 +288,12 @@ return () return xhr -parseAllHeadersString :: Text -> Map Text Text+parseAllHeadersString :: Text -> Map (CI Text) Text parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $ L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s- where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)+ where stripBoth (txt1, txt2) = (CI.mk $ T.strip txt1, T.strip $ T.drop 1 txt2) -newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest+newXMLHttpRequest :: (MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb -- | Given Event of requests, issue them when the Event fires.@@ -302,20 +302,20 @@ -- The request is processed asynchronously, therefore handling does -- not block or cause a delay while creating the connection. performRequestAsyncWithError- :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a)+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t (Either XhrException XhrResponse)) performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return -- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.-performRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)+performRequestAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse) performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return -- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.-performMkRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse)+performMkRequestAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse) performMkRequestAsync = performRequestAsync' newXMLHttpRequest -performRequestAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a)+performRequestAsync' :: (PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a) performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do r <- hr _ <- newXhr r $ liftIO . cb@@ -331,16 +331,16 @@ -- Order of request execution and completion is not guaranteed, but -- order of creation and the collection result is preserved. performRequestsAsyncWithError- :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a)+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse))) performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return -- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.-performRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))+performRequestsAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse)) performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return -- | Builds and issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.-performMkRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse))+performMkRequestsAsync :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse)) performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest performRequestsAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f) => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (f (XhrRequest b))) -> m (Event t (f a))@@ -354,7 +354,7 @@ return () -- | Simplified interface to "GET" URLs and return decoded results.-getAndDecode :: (MonadIO m, MonadJSM (Performable m), PerformEvent t m, HasJSContext (Performable m), TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a))+getAndDecode :: (MonadIO m, MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a)) getAndDecode url = do r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url return $ fmap decodeXhrResponse r@@ -444,7 +444,7 @@ xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4 {-# INLINE xhrResponse_responseText #-} -xhrResponse_headers :: Lens' XhrResponse (Map Text Text)+xhrResponse_headers :: Lens' XhrResponse (Map (CI Text) Text) xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5 {-# INLINE xhrResponse_headers #-}
src/Reflex/Dom/Xhr/Exception.hs view
@@ -1,12 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}- module Reflex.Dom.Xhr.Exception where import Control.Exception (Exception (..))-import Data.Typeable data XhrException = XhrException_Error | XhrException_Aborted- deriving (Show, Read, Eq, Ord, Typeable)+ deriving (Show, Read, Eq, Ord) instance Exception XhrException
src/Reflex/Dom/Xhr/Foreign.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE OverloadedStrings #-} module Reflex.Dom.Xhr.Foreign (@@ -15,7 +14,7 @@ import Data.ByteString (ByteString) import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer) import GHCJS.DOM.Enums-import GHCJS.DOM.EventM (EventM, on)+import GHCJS.DOM.EventM (EventM, on, onSync) import GHCJS.DOM.EventTarget (dispatchEvent) import GHCJS.DOM.Types (MonadJSM, ToJSString, FormData, Document, Blob (..), ArrayBuffer (..), JSVal, JSM, IsEvent, XMLHttpRequestProgressEvent, ProgressEvent, Event, XMLHttpRequestUpload, FromJSString, ArrayBufferView (..), liftJSM, castTo) import GHCJS.DOM.XMLHttpRequest@@ -114,7 +113,7 @@ xmlHttpRequestOntimeout = (`on` timeout) xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())-xmlHttpRequestOnreadystatechange = (`on` readyStateChange)+xmlHttpRequestOnreadystatechange = (`onSync` readyStateChange) xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m () xmlHttpRequestSetTimeout = setTimeout
src/Reflex/Dom/Xhr/FormData.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Reflex.Dom.Xhr.FormData ( postForms+ , postForms' , FormValue (..) , fileToFormValue )@@ -13,7 +14,6 @@ import Data.Text (Text) import Data.Traversable import qualified GHCJS.DOM.FormData as FD-import Foreign.JavaScript.TH import GHCJS.DOM.File (getName) import GHCJS.DOM.Types (File, IsBlob) import Language.Javascript.JSaddle.Monad (MonadJSM, liftJSM)@@ -26,19 +26,30 @@ -- | Performs a POST request with the provided FormData payload postForms- :: ( IsBlob blob, HasJSContext (Performable m), MonadJSM (Performable m)+ :: ( IsBlob blob, MonadJSM (Performable m) , PerformEvent t m, TriggerEvent t m , Traversable f) => Text -- ^ The target url -> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData" -> m (Event t (f XhrResponse))-postForms url payload = do+postForms t = postForms' t def++-- | Like 'postForms' but doesn't use a default 'XhrRequestConfig', so a custom one can be provided.+postForms'+ :: ( IsBlob blob, MonadJSM (Performable m)+ , PerformEvent t m, TriggerEvent t m+ , Traversable f)+ => Text -- ^ The target url+ -> XhrRequestConfig a+ -> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData"+ -> m (Event t (f XhrResponse))+postForms' url cfg payload = do performMkRequestsAsync $ ffor payload $ \fs -> for fs $ \u -> liftJSM $ do fd <- FD.newFormData Nothing iforM_ u $ \k v -> case v of FormValue_Text t -> FD.append fd k t FormValue_File b fn -> FD.appendBlob fd k b fn- return $ xhrRequest "POST" url $ def & xhrRequestConfig_sendData .~ fd+ return $ xhrRequest "POST" url $ cfg & xhrRequestConfig_sendData .~ fd -- | Converts a File (e.g., the output of a 'FileInput') into a 'FormValue'. The filename will be included if it is available. fileToFormValue :: MonadJSM m => File -> m (FormValue File)
src/Reflex/Dom/Xhr/ResponseType.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}- module Reflex.Dom.Xhr.ResponseType where import Data.ByteString (ByteString) import Data.Text (Text)-import Data.Typeable import GHCJS.DOM.Blob (Blob) data XhrResponseType@@ -12,7 +9,7 @@ | XhrResponseType_ArrayBuffer | XhrResponseType_Blob | XhrResponseType_Text- deriving (Show, Read, Eq, Ord, Typeable)+ deriving (Show, Read, Eq, Ord) data XhrResponseBody = XhrResponseBody_Default Text
test/gc.hs view
@@ -11,7 +11,6 @@ import Data.Text as T import Language.Javascript.JSaddle.Warp import Reflex.Dom.Core-import Reflex.Time import System.Exit import System.Mem import System.Process@@ -20,7 +19,7 @@ import Test.Util.UnshareNetwork #if MIN_VERSION_base(4,11,0)-import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)+import GHC.Stats (getRTSStats, RTSStats(..), gcdetails_live_bytes, gc) currentBytesUsed :: RTSStats -> Int64 currentBytesUsed = fromIntegral . gcdetails_live_bytes . gc #else@@ -47,7 +46,7 @@ main :: IO () main = do- handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother+ handle (\(_ :: IOError) -> return ()) $ unshareNetwork -- If we run into an exception with sandboxing, just don't bother withSandboxedChromeFlags True $ \chromeFlags -> do mainThread <- myThreadId browserProcess <- spawnCommand $ mconcat
test/hlint.hs view
@@ -1,10 +1,11 @@-import Language.Haskell.HLint3 (hlint)+import Language.Haskell.HLint (hlint) import System.Exit (exitFailure, exitSuccess) main :: IO () main = do ideas <- hlint [ "."+ , "--ignore=Functor law" , "--ignore=Redundant do" , "--ignore=Use camelCase" , "--ignore=Redundant $"@@ -20,7 +21,9 @@ , "--ignore=Unnecessary hiding" -- Interferes with cross-version compatibility , "--ignore=Use <$>" , "--ignore=Reduce duplication" --TODO: Re-enable this test+ , "--ignore=Eta reduce" -- simplified subsumption , "--ignore=Use list comprehension"+ , "--ignore=Evaluate" , "--cpp-define=USE_TEMPLATE_HASKELL" ] if null ideas then exitSuccess else exitFailure
test/hydration.hs view
@@ -1,13 +1,10 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -15,13 +12,27 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}++-- Notice to those working on this test suite:+-- It doesn't appear to be possible to use --match to run a particular test, in+-- this situation the test may hang before reaching our code. This seems to+-- happen when the test is not the first test in the block. As a workaround, you+-- can just comment out the other tests. Also, using `xit` will cause the same+-- issue. `xit` tests must be the last tests in the session, or the session will+-- hang in the following test.+ import Prelude hiding (fail) import Control.Concurrent+import qualified Control.Concurrent.Async as Async+import Control.Lens.Operators import Control.Monad hiding (fail) import Control.Monad.Catch import Control.Monad.Fail@@ -31,12 +42,13 @@ import Data.Constraint.Extras import Data.Constraint.Extras.TH import Data.Dependent.Map (DMap)-import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))+import Data.Dependent.Sum (DSum(..), (==>)) import Data.Functor.Identity import Data.Functor.Misc import Data.GADT.Compare.TH import Data.GADT.Show.TH import Data.IORef (IORef)+import Data.List (sort) import Data.Maybe import Data.Proxy import Data.Text (Text)@@ -55,14 +67,13 @@ import System.IO.Temp import System.Process import System.Which (staticWhich)-import qualified Test.HUnit as HUnit (assertEqual, assertFailure)+import qualified Test.HUnit as HUnit import qualified Test.Hspec as H import qualified Test.Hspec.Core.Spec as H import Test.Hspec (xit) import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD) import qualified Test.Hspec.WebDriver as WD import Test.WebDriver (WD(..))-import Test.WebDriver.Exceptions (ServerError(..)) import qualified Data.ByteString.Lazy as LBS import qualified Data.Dependent.Map as DMap@@ -78,6 +89,11 @@ import Test.Util.ChromeFlags import Test.Util.UnshareNetwork ++#if !MIN_VERSION_webdriver(0,10,0)+deriving instance MonadMask WD+#endif+ chromium :: FilePath chromium = $(staticWhich "chromium") @@ -93,26 +109,22 @@ writeRef r = WD . writeRef r assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()-assertEqual a b = liftIO . HUnit.assertEqual a b+assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b assertFailure :: MonadIO m => String -> m () assertFailure = liftIO . HUnit.assertFailure +assertBool :: (MonadIO m) => String -> Bool -> m ()+assertBool msg bool = liftIO $ HUnit.assertBool msg bool+ chromeConfig :: Text -> [Text] -> WD.WDConfig chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig -keyMap :: DMap DKey Identity-keyMap = DMap.fromList- [ Key_Int ==> 0- , Key_Char ==> 'A'- ]- data DKey a where Key_Int :: DKey Int Key_Char :: DKey Char Key_Bool :: DKey Bool - textKey :: DKey a -> Text textKey = \case Key_Int -> "Key_Int"@@ -124,11 +136,26 @@ deriveGCompare ''DKey deriveGShow ''DKey +keyMap :: DMap DKey Identity+keyMap = DMap.fromList+ [ Key_Int ==> 0+ , Key_Char ==> 'A'+ ]++data Key2 a where+ Key2_Int :: Int -> Key2 Int+ Key2_Char :: Char -> Key2 Char++deriveGEq ''Key2+deriveGCompare ''Key2+deriveGShow ''Key2+deriveArgDict ''Key2+ deriving instance MonadFail WD main :: IO () main = do- unshareNetork+ unshareNetwork isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS" withSandboxedChromeFlags isHeadless $ \chromeFlags -> do withSeleniumServer $ \selenium -> do@@ -137,25 +164,25 @@ withDebugging <- isNothing <$> lookupEnv "NO_DEBUG" let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium } chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags- hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium -tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec tests withDebugging wdConfig caps _selenium = do let putStrLnDebug :: MonadIO m => Text -> m () putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m- session' = sessionWith wdConfig "" . using (map (,"") caps)+ session' t = sessionWith wdConfig t . using caps runWD m = runWDOptions (WdOptions False) $ do putStrLnDebug "before" r <- m putStrLnDebug "after" return r- testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b+ testWidgetStatic :: WD b -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -> WD b testWidgetStatic = testWidgetStaticDebug withDebugging- testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b- testWidget = testWidgetDebug withDebugging- testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b- testWidget' = testWidgetDebug' withDebugging- describe "text" $ session' $ do+ testWidget :: WD () -> WD b -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -> WD b+ testWidget = testWidgetDebug True withDebugging+ testWidget' :: WD a -> (a -> WD b) -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -> WD b+ testWidget' = testWidgetDebug' True withDebugging+ session' "text" $ do it "works" $ runWD $ do testWidgetStatic (checkBodyText "hello world") $ do text "hello world"@@ -216,7 +243,7 @@ click <- button "" void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click - describe "element" $ session' $ do+ session' "element" $ do it "works with domEvent Click" $ runWD $ do clickedRef <- liftIO $ newRef False testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do@@ -280,21 +307,78 @@ let click = domEvent Click e return () - describe "inputElement" $ do- describe "hydration" $ session' $ do+ session' "inputElement" $ do+ describe "static renderer" $ do+ it "sets value attribute" $ runWD $ do+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ testWidget' checkStatic checkHydrated $ void $ inputElement $ def+ & inputElementConfig_initialValue .~ "test"+ it "updates value attribute at postBuild" $ runWD $ do+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ _ <- inputElement $ def+ & inputElementConfig_initialValue .~ "test"+ & inputElementConfig_setValue .~ ("test-updated" <$ pb)+ pure ()+ it "sets checked attr appropriately" $ runWD $ do+ setCheckedChan <- liftIO newChan+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ pure e+ checkValue e = do+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ WD.moveToCenter e+ WD.click e -- Click to uncheck+ WD.attr e "checked" `shouldBeWithRetryM` Nothing+ liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ testWidget' checkStatic checkValue $ do+ setChecked <- triggerEventWithChan setCheckedChan+ _ <- inputElement $ def+ & initialAttributes .~ "type" =: "checkbox"+ & inputElementConfig_initialChecked .~ True+ & inputElementConfig_setChecked .~ setChecked+ pure ()+ it "sets checked attr appropriately at postbuild" $ runWD $ do+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ pure e+ checkValue e = do+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ testWidget' checkStatic checkValue $ do+ pb <- getPostBuild+ _ <- inputElement $ def+ & initialAttributes .~ "type" =: "checkbox"+ & inputElementConfig_initialChecked .~ False+ & inputElementConfig_setChecked .~ (True <$ pb)+ pure ()+ describe "hydration" $ do it "doesn't wipe user input when switching over" $ runWD $ do- inputRef <- newRef ("" :: Text)+ inputRef <- newRef ("hello " :: Text) testWidget' (do e <- findElemWithRetry $ WD.ByTag "input"- WD.sendKeys "hello world" e+ WD.sendKeys "world" e pure e) (\e -> do WD.attr e "value" `shouldBeWithRetryM` Just "hello world" WD.click =<< findElemWithRetry (WD.ByTag "button") readRef inputRef `shouldBeWithRetryM` "hello world" ) $ do- e <- inputElement def+ e <- inputElement $ def & inputElementConfig_initialValue .~ "hello " click <- button "save" performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click it "captures user input after switchover" $ runWD $ do@@ -351,24 +435,49 @@ checkedByUIRef <- newRef False checkedRef <- newRef False setCheckedChan <- liftIO newChan- let checkValue = do+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "checked" `shouldBeWithRetryM` Nothing+ pure e+ checkValue e = do readRef checkedByUIRef `shouldBeWithRetryM` False readRef checkedRef `shouldBeWithRetryM` False- e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "checked" `shouldBeWithRetryM` Nothing WD.moveToCenter e WD.click e readRef checkedByUIRef `shouldBeWithRetryM` True readRef checkedRef `shouldBeWithRetryM` True+ WD.attr e "checked" `shouldBeWithRetryM` Just "true" liftIO $ writeChan setCheckedChan False readRef checkedByUIRef `shouldBeWithRetryM` True readRef checkedRef `shouldBeWithRetryM` False- testWidget (pure ()) checkValue $ do+ WD.attr e "checked" `shouldBeWithRetryM` Nothing+ testWidget' checkStatic checkValue $ do setChecked <- triggerEventWithChan setCheckedChan e <- inputElement $ def & initialAttributes .~ "type" =: "checkbox" & inputElementConfig_setChecked .~ setChecked performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)+ it "respects user updates to checked which happen before hydration" $ runWD $ do+ checkedByUIRef <- newRef False+ checkedRef <- newRef False+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "checked" `shouldBeWithRetryM` Nothing+ WD.moveToCenter e+ WD.click e+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ pure e+ checkValue e = do+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"+ readRef checkedByUIRef `shouldBeWithRetryM` True+ readRef checkedRef `shouldBeWithRetryM` True+ testWidget' checkStatic checkValue $ do+ e <- inputElement $ def+ & initialAttributes .~ "type" =: "checkbox"+ performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e+ performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e) it "captures file uploads" $ runWD $ do filesRef :: IORef [Text] <- newRef [] let uploadFile = do@@ -384,8 +493,117 @@ prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do names <- liftJSM $ traverse File.getName fs liftIO $ writeRef filesRef names-- describe "hydration/immediate" $ session' $ do+ it "fires _input event if the user altered the value before hydration" $ runWD $ do+ input <- newRef ("" :: Text)+ update <- newRef ("" :: Text)+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "value" `shouldBeWithRetryM` Just ""+ WD.sendKeys "test" e+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ readRef input `shouldBeWithRetryM` "test"+ readRef update `shouldBeWithRetryM` "test"+ testWidget' checkStatic checkHydrated $ do+ e <- inputElement def+ performEvent_ $ liftIO . writeRef input <$> _inputElement_input e+ performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)+ it "does not fire _input event when the value is updated at postBuild" $ runWD $ do+ input <- newRef (Nothing :: Maybe Text)+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "input"+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"+ readRef input `shouldBeWithRetryM` Nothing+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)+ performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e+ it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do+ let checkBoth = do+ input <- findElemWithRetry $ WD.ByTag "input"+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"+ p <- findElemWithRetry (WD.ByTag "p")+ shouldContainText "pb" p+ testWidget checkBoth checkBoth $ do+ pb <- getPostBuild+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)+ el "p" $ dynText $ _inputElement_value e+ it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do+ let checkStatic = do+ input <- findElemWithRetry $ WD.ByTag "input"+ h2_value <- findElemWithRetry (WD.ByTag "h2")+ h3_input <- findElemWithRetry (WD.ByTag "h3")+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"+ shouldContainText "pb" h2_value+ shouldContainText "" h3_input+ WD.sendKeys "abc" input+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pb" h2_value+ shouldContainText "" h3_input+ pure (input, h2_value, h3_input)+ checkHydrated (input, h2_value, h3_input) = do+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pbabc" h3_input+ shouldContainText "pbabc pb" h2_value+ pure ()+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)+ el "h1" $ dynText $ _inputElement_value e+ el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e+ el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e+ it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do+ let checkStatic = do+ input <- findElemWithRetry $ WD.ByTag "input"+ p <- findElemWithRetry (WD.ByTag "p")+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"+ shouldContainText "pb" p+ WD.sendKeys "abc" input+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pb" p -- It won't be updated yet+ pure (input, p)+ checkHydrated (input, p) = do+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pbabc" p+ pure ()+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)+ el "p" $ dynText $ _inputElement_value e+ it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do+ valRef <- newRef ([] :: [Text])+ inputRef <- newRef ([] :: [Text])+ let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())+ checkStatic = do+ input <- findElemWithRetry $ WD.ByTag "input"+ p <- findElemWithRetry (WD.ByTag "p")+ WD.attr input "value" `shouldBeWithRetryM` Just "pb"+ shouldContainText "pb" p+ WD.sendKeys "abc" input+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pb" p -- It won't be updated yet+ readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR+ readRef valRef `shouldBeWithRetryM` ["pb"]+ pure (input, p)+ checkHydrated (input, p) = do+ readRef inputRef `shouldBeWithRetryM` ["pbabc"]+ readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]+ WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pbabc" p+ pure ()+ testWidget' checkStatic checkHydrated $ do+ liftIO $ writeRef valRef []+ pb <- getPostBuild+ e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)+ el "p" $ dynText $ _inputElement_value e+ performEvent_ $ consRef valRef <$> updated (_inputElement_value e)+ performEvent_ $ consRef inputRef <$> _inputElement_input e+ describe "hydration/immediate" $ do it "captures user input after switchover" $ runWD $ do inputRef :: IORef Text <- newRef "" let checkValue = do@@ -465,8 +683,31 @@ names <- liftJSM $ traverse File.getName fs liftIO $ writeRef filesRef names - describe "textAreaElement" $ do- describe "hydration" $ session' $ do+ session' "textAreaElement" $ do+ describe "static renderer" $ do+ it "sets value attribute" $ runWD $ do+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "textarea"+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def+ & textAreaElementConfig_initialValue .~ "test"+ it "updates value attribute at postBuild" $ runWD $ do+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "textarea"+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ _ <- textAreaElement $ def+ & textAreaElementConfig_initialValue .~ "test"+ & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)+ pure ()+ describe "hydration" $ do it "doesn't wipe user input when switching over" $ runWD $ do inputRef <- newRef ("" :: Text) testWidget'@@ -532,8 +773,90 @@ e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' } performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)+ it "fires _input event if the user altered the value before hydration" $ runWD $ do+ textarea <- newRef ("" :: Text)+ update <- newRef ("" :: Text)+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "textarea"+ WD.attr e "value" `shouldBeWithRetryM` Just ""+ WD.sendKeys "test" e+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "test"+ readRef textarea `shouldBeWithRetryM` "test"+ readRef update `shouldBeWithRetryM` "test"+ testWidget' checkStatic checkHydrated $ do+ e <- textAreaElement def+ performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e+ performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)+ it "does not fire _input event when the value is updated at postBuild" $ runWD $ do+ textarea <- newRef (Nothing :: Maybe Text)+ let checkStatic = do+ e <- findElemWithRetry $ WD.ByTag "textarea"+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"+ pure e+ checkHydrated e = do+ WD.attr e "value" `shouldBeWithRetryM` Just "pb"+ readRef textarea `shouldBeWithRetryM` Nothing+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)+ performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e+ it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do+ let checkBoth = do+ textarea <- findElemWithRetry $ WD.ByTag "textarea"+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"+ p <- findElemWithRetry (WD.ByTag "p")+ shouldContainText "pb" p+ testWidget checkBoth checkBoth $ do+ pb <- getPostBuild+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)+ el "p" $ dynText $ _textAreaElement_value e+ it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do+ let checkStatic = do+ textarea <- findElemWithRetry $ WD.ByTag "textarea"+ h2_value <- findElemWithRetry (WD.ByTag "h2")+ h3_input <- findElemWithRetry (WD.ByTag "h3")+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"+ shouldContainText "pb" h2_value+ shouldContainText "" h3_input+ WD.sendKeys "abc" textarea+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pb" h2_value+ shouldContainText "" h3_input+ pure (textarea, h2_value, h3_input)+ checkHydrated (textarea, h2_value, h3_input) = do+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pbabc" h3_input+ shouldContainText "pbabc pb" h2_value+ pure ()+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)+ el "h1" $ dynText $ _textAreaElement_value e+ el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e+ el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e+ it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do+ let checkStatic = do+ textarea <- findElemWithRetry $ WD.ByTag "textarea"+ p <- findElemWithRetry (WD.ByTag "p")+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"+ shouldContainText "pb" p+ WD.sendKeys "abc" textarea+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pb" p -- It won't be updated yet+ pure (textarea, p)+ checkHydrated (textarea, p) = do+ WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"+ shouldContainText "pbabc" p+ pure ()+ testWidget' checkStatic checkHydrated $ do+ pb <- getPostBuild+ e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)+ el "p" $ dynText $ _textAreaElement_value e - describe "hydration/immediate" $ session' $ do+ describe "hydration/immediate" $ do it "captures user input after switchover" $ runWD $ do inputRef :: IORef Text <- newRef "" let checkValue = do@@ -575,13 +898,13 @@ performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e performEvent_ $ liftIO . writeRef valueRef <$> updated (value e) - describe "selectElement" $ do+ session' "selectElement" $ do let options :: DomBuilder t m => m () options = do elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one" elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two" elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"- describe "hydration" $ session' $ do+ describe "hydration" $ do it "sets initial value correctly" $ runWD $ do inputRef <- newRef ("" :: Text) let setup = do@@ -655,7 +978,7 @@ performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e) - describe "hydration/immediate" $ session' $ do+ describe "hydration/immediate" $ do it "captures user input after switchover" $ runWD $ do inputRef :: IORef Text <- newRef "" let checkValue = do@@ -701,7 +1024,7 @@ performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e) - describe "prerender" $ session' $ do+ session' "prerender" $ do it "works in simple case" $ runWD $ do testWidget (checkBodyText "One") (checkBodyText "Two") $ do prerender_ (text "One") (text "Two")@@ -770,7 +1093,16 @@ prerender_ (pure ()) (liftIO $ trigger "Client") textNode $ TextNodeConfig "Initial" $ Just e - describe "runWithReplace" $ session' $ do+ session' "namespaces" $ do+ it "dyn can be nested in namespaced widget" $ runWD $ do+ testWidget (pure ()) (checkTextInTag "svg" "one") $ do+ let svgRootCfg = def+ & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")+ & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))+ void $ element "svg" svgRootCfg $ do+ dyn_ $ text "one" <$ pure ()++ session' "runWithReplace" $ do it "works" $ runWD $ do replaceChan :: Chan Text <- liftIO newChan let setup = findElemWithRetry $ WD.ByTag "div"@@ -914,7 +1246,61 @@ , el "span" . text <$> replace ] - describe "traverseDMapWithKeyWithAdjust" $ session' $ do+ let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)+ it "removes bracketing comments" $ runWD $ do+ replaceChan :: Chan () <- liftIO newChan+ let+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"+ check () = do+ liftIO $ writeChan replaceChan () -- trigger creation of p tag+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created+ checkInnerHtml "div" "before|<p>inner2</p>|after"+ testWidget' preSwitchover check $ do+ replace <- triggerEventWithChan replaceChan+ el "div" $ do+ text "before|"+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace+ text "|after"+ it "ignores extra ending bracketing comment" $ runWD $ do+ replaceChan :: Chan () <- liftIO newChan+ let+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"+ check () = do+ liftIO $ writeChan replaceChan () -- trigger creation of p tag+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created+ checkInnerHtml "div" "before|inner2|after"+ testWidget' preSwitchover check $ do+ replace <- triggerEventWithChan replaceChan+ el "div" $ do+ text "before|"+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace+ text "|after"+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test+ -- TODO This test actually causes a hydration failure, but it wasn't+ -- previously detected, so I've marked it pending+ xit "ignores missing ending bracketing comments" $ runWD $ do+ replaceChan :: Chan () <- liftIO newChan+ let+ preSwitchover = do+ checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"+ divEl <- findElemWithRetry (WD.ByTag "div")+ let wrongHtml = "<!--replace-start-0-->inner1"+ actualHtml :: String <- WD.executeJS+ [WD.JSArg divEl, WD.JSArg wrongHtml]+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"+ actualHtml `shouldBe` wrongHtml+ check () = do+ liftIO $ writeChan replaceChan () -- trigger creation of p tag+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created+ checkInnerHtml "div" "before|<p>inner2</p>|after"+ testWidget' preSwitchover check $ do+ replace <- triggerEventWithChan replaceChan+ el "div" $ do+ text "before|"+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace+ text "|after"++ session' "traverseDMapWithKeyWithAdjust" $ do let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a) widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do elClass "span" "key" $ text $ textKey k@@ -1017,7 +1403,7 @@ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace] liftIO $ dmap `H.shouldBe` keyMap - describe "traverseIntMapWithKeyWithAdjust" $ session' $ do+ session' "traverseIntMapWithKeyWithAdjust" $ do let textKeyInt k = "key" <> T.pack (show k) intMap = IntMap.fromList [ (1, "one")@@ -1124,7 +1510,7 @@ (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace] liftIO $ dmap `H.shouldBe` intMap - describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a) widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do elClass "span" "key" $ text $ textKey2 k@@ -1204,8 +1590,8 @@ (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan liftIO $ assertEqual "DMap" initMap dmap - describe "hydrating invalid HTML" $ session' $ do- it "can hydrate list in paragraph" $ runWD $ do+ session' "hydrating invalid HTML" $ do+ xit "can hydrate list in paragraph" $ runWD $ do let preSwitchover = do checkBodyText "before\ninner\nafter" -- Two <p> tags should be present@@ -1222,7 +1608,8 @@ shouldContainText "before\ninner\nafter" p1 elementShouldBeRemoved ol elementShouldBeRemoved p2- testWidget' preSwitchover check $ do+ -- Don't fail fatally when hydration encounters the invalid DOM+ testWidgetDebug' False withDebugging preSwitchover check $ do -- This is deliberately invalid HTML, the browser will interpret it as -- <p>before</p><ol>inner</ol>after<p></p> el "p" $ do@@ -1230,6 +1617,29 @@ el "ol" $ text "inner" text "after" + -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.+ -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.+ -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.+ session' "dropdown" $ do+ let doTest expectedOpts (initialValue :: Text) = do+ let doCheck = do+ es <- findElemsWithRetry $ WD.ByTag "option"+ opts <- mapM fetchElement es+ assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)+ testWidget doCheck doCheck $ do+ void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def+ fetchElement e = do+ val <- WD.attr e "value"+ sel <- WD.attr e "selected"+ return (fromMaybe "" val, isJust sel)+ -- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)+ -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.+ xit "statically renders initial values (on aa)" $ runWD $ do+ doTest [("0",True),("1",False)] "aa"+ -- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well+ xit "statically renders initial values (on bb)" $ runWD $ do+ doTest [("0",False),("1",True)] "bb"+ data Selenium = Selenium { _selenium_portNumber :: PortNumber , _selenium_stopServer :: IO ()@@ -1253,7 +1663,7 @@ , _selenium_stopServer = stopServer } -triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender js t m) => Chan a -> m (Event t a)+triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender t m) => Chan a -> m (Event t a) triggerEventWithChan chan = do (e, trigger) <- newTriggerEvent -- In prerender because we only want to do this on the client@@ -1297,6 +1707,9 @@ findElemWithRetry :: Selector -> WD WD.Element findElemWithRetry = withRetry . WD.findElem +findElemsWithRetry :: Selector -> WD [WD.Element]+findElemsWithRetry = withRetry . WD.findElems+ getBody :: WD WD.Element getBody = WD.findElem $ WD.ByTag "body" @@ -1305,49 +1718,54 @@ where wait :: Int -> WD a wait 0 = a wait n = try a >>= \case- Left (_ :: SomeException) -> do- liftIO $ threadDelay 100000+ Left (e :: SomeException) -> do+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000 wait $ n - 1 Right v -> return v divId :: DomBuilder t m => Text -> m a -> m a divId i = elAttr "div" ("id" =: i) -type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)+type TestWidget t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m) testWidgetStaticDebug :: Bool -> WD b -- ^ Webdriver commands to run before JS runs and after hydration switchover- -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())+ -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -- ^ Widget we are testing -> WD b-testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w+testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w -- | TODO: do something about JSExceptions not causing tests to fail testWidgetDebug :: Bool+ -> Bool -> WD () -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page) -> WD b -- ^ Webdriver commands to run after hydration switchover- -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())+ -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -- ^ Widget we are testing -> WD b-testWidgetDebug withDebugging beforeJS afterSwitchover =- testWidgetDebug' withDebugging beforeJS (const afterSwitchover)+testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =+ testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover) +data HydrationFailedException = HydrationFailedException deriving Show+instance Exception HydrationFailedException+ -- | TODO: do something about JSExceptions not causing tests to fail testWidgetDebug' :: Bool+ -> Bool -> WD a -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page) -> (a -> WD b) -- ^ Webdriver commands to run after hydration switchover- -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())+ -> (forall m. TestWidget (SpiderTimeline Global) m => m ()) -- ^ Widget we are testing (contents of body) -> WD b-testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do+testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do let putStrLnDebug :: MonadIO m => Text -> m () putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m staticApp = do@@ -1359,6 +1777,7 @@ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp putStrLnDebug "rendered static" waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run+ onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure () waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover let entryPoint = do putStrLnDebug "taking waitBeforeJS"@@ -1370,7 +1789,7 @@ liftIO $ putMVar waitUntilSwitchover () putStrLnDebug "put waitUntilSwitchover" putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"- mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction" syncPoint application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do@@ -1388,29 +1807,23 @@ ] -- hSilence to get rid of ConnectionClosed logs silenceIfDebug = if withDebugging then id else hSilence [stderr]- jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application- jsaddleTid <- liftIO jsaddleWarp- putStrLnDebug "taking waitJSaddle"- liftIO $ takeMVar waitJSaddle- putStrLnDebug "opening page"- WD.openPage $ "http://localhost:" <> show jsaddlePort- putStrLnDebug "running beforeJS"- a <- beforeJS- putStrLnDebug "putting waitBeforeJS"- liftIO $ putMVar waitBeforeJS ()- putStrLnDebug "taking waitUntilSwitchover"- liftIO $ takeMVar waitUntilSwitchover- putStrLnDebug "running afterSwitchover"- b <- afterSwitchover a- putStrLnDebug "killing jsaddle thread"- liftIO $ killThread jsaddleTid- return b--data Key2 a where- Key2_Int :: Int -> Key2 Int- Key2_Char :: Char -> Key2 Char+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application+ withAsync' jsaddleWarp $ do+ putStrLnDebug "taking waitJSaddle"+ liftIO $ takeMVar waitJSaddle+ putStrLnDebug "opening page"+ WD.openPage $ "http://localhost:" <> show jsaddlePort+ putStrLnDebug "running beforeJS"+ a <- beforeJS+ putStrLnDebug "putting waitBeforeJS"+ liftIO $ putMVar waitBeforeJS ()+ putStrLnDebug "taking waitUntilSwitchover"+ liftIO $ takeMVar waitUntilSwitchover+ putStrLnDebug "running afterSwitchover"+ afterSwitchover a -deriveGEq ''Key2-deriveGCompare ''Key2-deriveGShow ''Key2-deriveArgDict ''Key2+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b+withAsync' f g = bracket+ (liftIO $ Async.async f)+ (liftIO . Async.uninterruptibleCancel)+ (const g)