git.iko.soy/reflex-dom
on develop help sign in
Merge branch 'develop' into paste-event
02ff86eRyan Trinkle
FAQ.mdnew file+31
compare with develop
unifiedsplit
@@ -0,0 +1,31 @@
1+# Frequently Asked Questions
2+
3+### How do I configure DOM events with flags like `preventDefault` and `stopPropagation`?
4+
5+Using `element`, a low-level DOM builder function. Its second argument, `ElementConfig`, has a `_elementConfig_eventSpec` field that can be modified using `addEventSpecFlags`. It takes a `Proxy` that specifies the `DomSpace`, an event name, and a callback which takes the event result and returns an event flag, which can enable behavior like `preventDefault` and `stopPropagation`.
6+
7+The type signature on `def` is needed because the fields of the `ElementConfig` can change the type of the `ElementConfig`. GHC can probably figure out the type of the resulting `ElementConfig`, but it doesn't know what the type of `def` was before the modifications, since it never gets used with that configuration.
8+
9+For example:
10+
11+```haskell
12+{-# LANGUAGE OverloadedStrings #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+
15+import Control.Lens ((&), (%~), (.~))
16+import Data.Proxy
17+import Reflex.Dom
18+
19+main :: IO ()
20+main = mainWidget $ do
21+ (click, ()) <- linkPreventDefault $ text "reflex-frp"
22+ display =<< count click
23+
24+linkPreventDefault :: forall t m a. DomBuilder t m => m a -> m (Event t (), a)
25+linkPreventDefault c = do
26+ let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
27+ & elementConfig_initialAttributes .~ ("href" =: "https://reflex-frp.org")
28+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (const preventDefault)
29+ (link, a) <- element "a" cfg c
30+ return (domEvent Click link, a)
31+```
cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: reflex-dom-core, reflex-dom
default.nixdeleted−53
@@ -1,53 +0,0 @@
1−haskellPackages: let
2− pkgs = haskellPackages.callPackage ({ pkgs }: pkgs) {};
3− inherit (pkgs) stdenv;
4− haskellLib = pkgs.haskell.lib;
5−in {
6− reflex-dom-core = let
7− inherit (haskellPackages) ghc;
8− noGcTest = stdenv.hostPlatform.system != "x86_64-linux"
9− || stdenv.hostPlatform != stdenv.buildPlatform
10− || (ghc.isGhcjs or false);
11− in haskellLib.overrideCabal
12− (haskellPackages.callCabal2nix "reflex-dom-core" ./reflex-dom-core { })
13− (drv: {
14− #TODO: Get hlint working for cross-compilation
15− doCheck = stdenv.hostPlatform == stdenv.buildPlatform && !(ghc.isGhcjs or false);
16−
17− # The headless browser run as part of the tests will exit without this
18− preBuild = ''
19− export HOME="$PWD"
20− '';
21−
22− # Show some output while running tests, so we might notice what's wrong
23− testTarget = "--show-details=streaming";
24−
25− testHaskellDepends = with haskellPackages; (drv.testHaskellDepends or []) ++ stdenv.lib.optionals (!noGcTest) [
26− temporary
27− jsaddle-warp
28− process
29− chrome-test-utils
30− ];
31−
32− testSystemDepends = with pkgs; (drv.testSystemDepends or []) ++ [
33− selenium-server-standalone which
34− ] ++ stdenv.lib.optionals (!noGcTest) [
35− chromium
36− pkgs.iproute
37− ];
38− } // stdenv.lib.optionalAttrs (!noGcTest) {
39− # The headless browser run as part of gc tests would hang/crash without this
40− preCheck = ''
41− export FONTCONFIG_PATH=${pkgs.fontconfig.out}/etc/fonts
42− '';
43− });
44− reflex-dom = haskellLib.overrideCabal
45− (haskellPackages.callCabal2nix "reflex-dom" ./reflex-dom { })
46− (drv: {
47− # Hack until https://github.com/NixOS/cabal2nix/pull/432 lands
48− libraryHaskellDepends = (drv.libraryHaskellDepends or []) ++ stdenv.lib.optionals (with stdenv.hostPlatform; isAndroid && is32bit) [
49− haskellPackages.android-activity
50− ];
51− });
52− chrome-test-utils = haskellPackages.callCabal2nix "chrome-test-utils" ./chrome-test-utils {};
53−}
dep/reflex-platform/github.json+3−3
@@ -1,7 +1,7 @@
1{
1{
2 "owner": "reflex-frp",
2 "owner": "reflex-frp",
3 "repo": "reflex-platform",
3 "repo": "reflex-platform",
4− "branch": "develop",
4+ "branch": "master",
5− "rev": "338fc907e37d70e6469c529456f33221fb05ca1f",
5+ "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
6− "sha256": "08gfhpp0pkvvi1wnlpcn6wmpzdjvy5z7dy1h66gp2w8b5cx8hx5h"
6+ "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
7}
7}
reflex-dom-core/ChangeLog.md+54
@@ -2,24 +2,78 @@
2
2
3## Unreleased
3## Unreleased
4
4
5+* ([#353](https://github.com/reflex-frp/reflex-dom/pull/353)) Support GHC 8.8.
6+* ([#358](https://github.com/reflex-frp/reflex-dom/pull/358)) Fix attribute support for explicitly namespaced elements.
7+* ([#363](https://github.com/reflex-frp/reflex-dom/pull/363)) Remove deprecation warnings for the following widgets in
8+ `Reflex.Dom.Widget.Basic`:
9+
10+ * `Link`
11+ * `button`
12+ * `dtdd`
13+ * `linkClass`
14+ * `link`
15+ * `tabDisplay`
16+ * `tableDynAttr`
17+* ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)) Fix bug in hydration causing the JavaScript to crash when dealing with unexpected HTML.
18+* ([#364](https://github.com/reflex-frp/reflex-dom/pull/364)) Export attributes used for controlling hydration at the element level:
19+ * "data-ssr" is now available as `Reflex.Dom.Builder.Immediate.hydratableAttribute`.
20+ * "data-hydration-skip" is now available as `Reflex.Dom.Builder.Immediate.skipHydrationAttribute`.
21+* ([#348](https://github.com/reflex-frp/reflex-dom/pull/348)) **(Breaking change)** Make XHR response headers case insensitive by changing `_xhrResponse_headers :: Map Text Text` to `_xhrResponse_headers :: Map (CI Text) Text`.
22+* ([#225](https://github.com/reflex-frp/reflex-dom/pull/225)) **(Breaking change)** Add a functional dependency to `HasDomEvent`.
23+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
24+
25+
26+## 0.5.3
27+
28+* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:
29+
30+ * `Link`
31+ * `button`
32+ * `dtdd`
33+ * `linkClass`
34+ * `link`
35+ * `tabDisplay`
36+ * `tableDynAttr`
37+
38+ And in `Reflex.Dom.Widget.Input`:
39+
40+ * `TextInput`
41+ * `TextAreaConfig`
42+ * `CheckboxConfig`
43+ * `FileInput`
44+
45+ * Add `< 0.7` upper bound for reflex
46+
47+* *(Breaking change)* The mouse wheel event now is a `WheelEventResult` rather than `()`.
48+ This provides information about the wheel's motion beyond the fact that it merely moved.
49+
5## 0.5.2
50## 0.5.2
6
51
7* Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).
52* Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).
53+
8* Update version bounds of base, containers, and stm
54* Update version bounds of base, containers, and stm
55+
9* Update to use the newly split `these`/`semialign` packages. To use the pre-split `these` package, set the `split-these` flag to false.
56* Update to use the newly split `these`/`semialign` packages. To use the pre-split `these` package, set the `split-these` flag to false.
57+
10* Reintroduce "data-ssr": elements without this attribute are skipped during
58* Reintroduce "data-ssr": elements without this attribute are skipped during
11 hydration.
59 hydration.
60+
12* Fix an issue in the hydration tests that prevented the test from finding the chromium executable
61* Fix an issue in the hydration tests that prevented the test from finding the chromium executable
62+
13* Relax constraints on `dyn` and `widgetHold` to match the ones in `networkView` and `networkHold` respectively
63* Relax constraints on `dyn` and `widgetHold` to match the ones in `networkView` and `networkHold` respectively
64+
14* 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
65* 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
15
66
16## 0.5.1
67## 0.5.1
17
68
18* Added support for marking elements with a "data-skip-hydration" attribute, which will cause hydration to ignore and skip over them.
69* Added support for marking elements with a "data-skip-hydration" attribute, which will cause hydration to ignore and skip over them.
70+
19* Removed "data-ssr" attributes from statically rendered output.
71* Removed "data-ssr" attributes from statically rendered output.
20
72
21## 0.5
73## 0.5
22
74
23* Add HydrationDomBuilderT to support hydration of statically rendered DOM nodes. See the note at the top of Reflex.Dom.Builder.Immediate.
75* Add HydrationDomBuilderT to support hydration of statically rendered DOM nodes. See the note at the top of Reflex.Dom.Builder.Immediate.
76+
24* 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.
77* 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.
78+
25* Add the Reflex.Dom.Xhr.FormData module to make posting formdata over xhr more convenient.
79* Add the Reflex.Dom.Xhr.FormData module to make posting formdata over xhr more convenient.
reflex-dom-core/reflex-dom-core.cabal+10−8
@@ -1,5 +1,5 @@
1Name: reflex-dom-core
1Name: reflex-dom-core
2−Version: 0.5.2.0
2+Version: 0.5.3
3Synopsis: Functional Reactive Web Apps with Reflex
3Synopsis: Functional Reactive Web Apps with Reflex
4Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
4Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
5License: BSD3
5License: BSD3
@@ -48,11 +48,12 @@ library
48 hs-source-dirs: src
48 hs-source-dirs: src
49 build-depends:
49 build-depends:
50 aeson >= 0.8 && < 1.5,
50 aeson >= 0.8 && < 1.5,
51− base >= 4.7 && < 4.13,
51+ base >= 4.7 && < 4.14,
52 bifunctors >= 4.2 && < 6,
52 bifunctors >= 4.2 && < 6,
53 bimap >= 0.3 && < 0.4,
53 bimap >= 0.3 && < 0.4,
54 blaze-builder,
54 blaze-builder,
55 bytestring == 0.10.*,
55 bytestring == 0.10.*,
56+ case-insensitive < 1.3,
56 containers >= 0.6 && < 0.7,
57 containers >= 0.6 && < 0.7,
57 constraints >= 0.9 && < 0.12,
58 constraints >= 0.9 && < 0.12,
58 contravariant >= 1.4 && < 1.6,
59 contravariant >= 1.4 && < 1.6,
@@ -63,17 +64,17 @@ library
63 directory >= 1.2 && < 1.4,
64 directory >= 1.2 && < 1.4,
64 exception-transformers == 0.4.*,
65 exception-transformers == 0.4.*,
65 ghcjs-dom >= 0.9.1.0 && < 0.10,
66 ghcjs-dom >= 0.9.1.0 && < 0.10,
66− jsaddle >=0.9.0.0 && <0.10,
67+ jsaddle >= 0.9.0.0 && < 0.10,
67 -- keycode-0.2 has a bug on firefox
68 -- keycode-0.2 has a bug on firefox
68 keycode >= 0.2.1 && < 0.3,
69 keycode >= 0.2.1 && < 0.3,
69 lens >= 4.7 && < 5,
70 lens >= 4.7 && < 5,
70 monad-control >= 1.0.1 && < 1.1,
71 monad-control >= 1.0.1 && < 1.1,
71 mtl >= 2.1 && < 2.3,
72 mtl >= 2.1 && < 2.3,
72− primitive >= 0.5 && < 0.7,
73+ primitive >= 0.5 && < 0.8,
73 random,
74 random,
74 ref-tf == 0.4.*,
75 ref-tf == 0.4.*,
75− reflex >= 0.6.2,
76+ reflex >= 0.6.2 && < 0.8,
76− semigroups >= 0.16 && < 0.19,
77+ semigroups >= 0.16 && < 0.20,
77 stm >= 2.4 && < 2.6,
78 stm >= 2.4 && < 2.6,
78 text == 1.2.*,
79 text == 1.2.*,
79 transformers >= 0.3 && < 0.6,
80 transformers >= 0.3 && < 0.6,
@@ -84,7 +85,7 @@ library
84 hs-source-dirs: src-ghcjs
85 hs-source-dirs: src-ghcjs
85 build-depends:
86 build-depends:
86 ghcjs-base,
87 ghcjs-base,
87− hashable == 1.2.*
88+ hashable >= 1.2 && < 1.4
88 else
89 else
89 hs-source-dirs: src-ghc
90 hs-source-dirs: src-ghc
90 if !os(windows)
91 if !os(windows)
@@ -92,7 +93,7 @@ library
92
93
93 if flag(split-these)
94 if flag(split-these)
94 build-depends:
95 build-depends:
95− semialign >= 1 && < 1.1,
96+ semialign >= 1 && < 1.2,
96 these >= 1 && < 1.1
97 these >= 1 && < 1.1
97 else
98 else
98 build-depends:
99 build-depends:
@@ -166,6 +167,7 @@ test-suite hlint
166test-suite hydration
167test-suite hydration
167 build-depends: base
168 build-depends: base
168 , aeson
169 , aeson
170+ , async
169 , bytestring
171 , bytestring
170 , chrome-test-utils
172 , chrome-test-utils
171 , constraints
173 , constraints
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+1−1
@@ -638,7 +638,7 @@ instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive
638
638
639-- * Convenience functions
639-- * Convenience functions
640
640
641−class HasDomEvent t target eventName where
641+class HasDomEvent t target eventName | target -> t where
642 type DomEventType target eventName :: *
642 type DomEventType target eventName :: *
643 domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)
643 domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)
644
644
reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+11−1
@@ -160,7 +160,17 @@ type family EventResultType (en :: EventTag) :: * where
160 EventResultType 'TouchmoveTag = TouchEventResult
160 EventResultType 'TouchmoveTag = TouchEventResult
161 EventResultType 'TouchendTag = TouchEventResult
161 EventResultType 'TouchendTag = TouchEventResult
162 EventResultType 'TouchcancelTag = TouchEventResult
162 EventResultType 'TouchcancelTag = TouchEventResult
163− EventResultType 'WheelTag = ()
163+ EventResultType 'WheelTag = WheelEventResult
164+
165+data DeltaMode = DeltaPixel | DeltaLine | DeltaPage
166+ deriving (Show, Read, Eq, Ord, Bounded, Enum)
167+
168+data WheelEventResult = WheelEventResult
169+ { _wheelEventResult_deltaX :: Double
170+ , _wheelEventResult_deltaY :: Double
171+ , _wheelEventResult_deltaZ :: Double
172+ , _wheelEventResult_deltaMode :: DeltaMode
173+ } deriving (Show, Read, Eq, Ord)
164
174
165data TouchEventResult = TouchEventResult
175data TouchEventResult = TouchEventResult
166 { _touchEventResult_altKey :: Bool
176 { _touchEventResult_altKey :: Bool
reflex-dom-core/src/Reflex/Dom/Builder/Hydratable.hs+4−4
@@ -21,10 +21,10 @@ import GHCJS.DOM.Types (MonadJSM (..))
21#endif
21#endif
22import Reflex
22import Reflex
23import Reflex.Dom.Builder.Class
23import Reflex.Dom.Builder.Class
24−import Reflex.Dom.Builder.Immediate (HasDocument (..))
24+import Reflex.Dom.Builder.Immediate (HasDocument (..), hydratableAttribute)
25import Reflex.Host.Class
25import Reflex.Host.Class
26
26
27−-- | A DomBuilder transformer that adds "data-ssr" to all elements such that the
27+-- | A DomBuilder transformer that adds an attribute to all elements such that the
28-- hydration builder knows which bits of DOM were added by us, and which were
28-- hydration builder knows which bits of DOM were added by us, and which were
29-- added by external scripts.
29-- added by external scripts.
30newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
30newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
@@ -62,8 +62,8 @@ instance PrimMonad m => PrimMonad (HydratableT m) where
62
62
63makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m
63makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m
64makeHydratable cfg = cfg
64makeHydratable cfg = cfg
65− { _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg
65+ { _elementConfig_initialAttributes = Map.insert hydratableAttribute "" $ _elementConfig_initialAttributes cfg
66− , _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg
66+ , _elementConfig_modifyAttributes = fmap (Map.delete hydratableAttribute) <$> _elementConfig_modifyAttributes cfg
67 }
67 }
68
68
69instance PostBuild t m => PostBuild t (HydratableT m) where
69instance PostBuild t m => PostBuild t (HydratableT m) where
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+75−39
@@ -107,6 +107,9 @@ module Reflex.Dom.Builder.Immediate
107 , WindowConfig (..)
107 , WindowConfig (..)
108 , Window (..)
108 , Window (..)
109 , wrapWindow
109 , wrapWindow
110+ -- * Attributes for controlling hydration
111+ , hydratableAttribute
112+ , skipHydrationAttribute
110 -- * Internal
113 -- * Internal
111 , traverseDMapWithKeyWithAdjust'
114 , traverseDMapWithKeyWithAdjust'
112 , hoistTraverseWithKeyWithAdjust
115 , hoistTraverseWithKeyWithAdjust
@@ -137,12 +140,13 @@ import Data.IntMap.Strict (IntMap)
137import Data.Maybe
140import Data.Maybe
138import Data.Monoid ((<>))
141import Data.Monoid ((<>))
139import Data.Some (Some(..))
142import Data.Some (Some(..))
143+import Data.String (IsString)
140import Data.Text (Text)
144import Data.Text (Text)
141import Foreign.JavaScript.Internal.Utils
145import Foreign.JavaScript.Internal.Utils
142import Foreign.JavaScript.TH
146import Foreign.JavaScript.TH
143import GHCJS.DOM.ClipboardEvent as ClipboardEvent
147import GHCJS.DOM.ClipboardEvent as ClipboardEvent
144import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
148import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
145−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
149+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
146import GHCJS.DOM.EventM (EventM, event, on)
150import GHCJS.DOM.EventM (EventM, event, on)
147import GHCJS.DOM.KeyboardEvent as KeyboardEvent
151import GHCJS.DOM.KeyboardEvent as KeyboardEvent
148import GHCJS.DOM.MouseEvent
152import GHCJS.DOM.MouseEvent
@@ -194,6 +198,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
194import qualified GHCJS.DOM.TouchList as TouchList
198import qualified GHCJS.DOM.TouchList as TouchList
195import qualified GHCJS.DOM.Types as DOM
199import qualified GHCJS.DOM.Types as DOM
196import qualified GHCJS.DOM.Window as Window
200import qualified GHCJS.DOM.Window as Window
201+import qualified GHCJS.DOM.WheelEvent as WheelEvent
197import qualified Reflex.Patch.DMap as PatchDMap
202import qualified Reflex.Patch.DMap as PatchDMap
198import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
203import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
199import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
204import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -320,8 +325,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
320addHydrationStepWithSetup setup f = getHydrationMode >>= \case
325addHydrationStepWithSetup setup f = getHydrationMode >>= \case
321 HydrationMode_Immediate -> pure ()
326 HydrationMode_Immediate -> pure ()
322 HydrationMode_Hydrating -> do
327 HydrationMode_Hydrating -> do
323− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
328+ s <- lift setup
324− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
325 addHydrationStep (f s)
329 addHydrationStep (f s)
326
330
327-- | Add a hydration step
331-- | Add a hydration step
@@ -745,6 +749,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
745 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
749 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
746 #-}
750 #-}
747
751
752+-- | An attribute which causes hydration to skip over an element completely.
753+skipHydrationAttribute :: IsString s => s
754+skipHydrationAttribute = "data-hydration-skip"
755+
756+-- | An attribute which signals that an element should be hydrated.
757+hydratableAttribute :: IsString s => s
758+hydratableAttribute = "data-ssr"
759+
748{-# INLINE hydrateElement #-}
760{-# INLINE hydrateElement #-}
749hydrateElement
761hydrateElement
750 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
762 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
@@ -766,18 +778,15 @@ hydrateElement elementTag cfg child = do
766 }
778 }
767 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
779 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
768 wrapResult <- liftIO newEmptyMVar
780 wrapResult <- liftIO newEmptyMVar
769− let skipAttr = "data-hydration-skip" :: DOM.JSString
781+ let -- Determine if we should skip an element. We currently skip elements for
770− ssrAttr = "data-ssr" :: DOM.JSString
782+ -- two reasons:
783+ -- 1) it was not produced by a static builder which supports hydration
784+ -- 2) it is explicitly marked to be skipped
771 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
785 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
772− shouldSkip e = case cfg ^. namespace of
786+ shouldSkip e = do
773− Nothing -> do
774− skip <- hasAttribute e skipAttr
787+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
775− ssr <- hasAttribute e ssrAttr
788+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
776− pure $ skip || not ssr
777− Just ns -> do
778− skip <- hasAttributeNS e (Just ns) skipAttr
779− ssr <- hasAttributeNS e (Just ns) ssrAttr
780− pure $ skip || not ssr
789+ pure $ skip || not hydratable
781 childDom <- liftIO $ readIORef childDelayedRef
790 childDom <- liftIO $ readIORef childDelayedRef
782 let rawCfg = extractRawElementConfig cfg
791 let rawCfg = extractRawElementConfig cfg
783 doc <- askDocument
792 doc <- askDocument
@@ -793,7 +802,7 @@ hydrateElement elementTag cfg child = do
793 Just node -> DOM.castTo DOM.Element node >>= \case
802 Just node -> DOM.castTo DOM.Element node >>= \case
794 Nothing -> go (Just node) -- this node is not an element, skip
803 Nothing -> go (Just node) -- this node is not an element, skip
795 Just e -> shouldSkip e >>= \case
804 Just e -> shouldSkip e >>= \case
796− True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
805+ True -> go (Just node) -- this element should be skipped by hydration
797 False -> do
806 False -> do
798 t <- Element.getTagName e
807 t <- Element.getTagName e
799 -- TODO: check attributes?
808 -- TODO: check attributes?
@@ -1279,8 +1288,8 @@ hydrateComment doc t mSetContents = do
1279skipToAndReplaceComment
1288skipToAndReplaceComment
1280 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1289 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1281 => Text
1290 => Text
1282− -> IORef Text
1291+ -> IORef (Maybe Text)
1283− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1292+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
1284skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1293skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1285 HydrationMode_Immediate -> do
1294 HydrationMode_Immediate -> do
1286 -- If we're in immediate mode, we don't try to replace an existing comment,
1295 -- If we're in immediate mode, we don't try to replace an existing comment,
@@ -1288,43 +1297,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1288 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
1297 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
1289 append $ toNode t
1298 append $ toNode t
1290 textNodeRef <- liftIO $ newIORef t
1299 textNodeRef <- liftIO $ newIORef t
1291− keyRef <- liftIO $ newIORef ""
1300+ keyRef <- liftIO $ newIORef Nothing
1292 pure (pure (), textNodeRef, keyRef)
1301 pure (pure (), textNodeRef, keyRef)
1293 HydrationMode_Hydrating -> do
1302 HydrationMode_Hydrating -> do
1294 doc <- askDocument
1303 doc <- askDocument
1295 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
1304 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
1296 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1305 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1306+ let
1307+ go Nothing _ = do
1308+ tn <- createTextNode doc ("" :: Text)
1309+ insertAfterPreviousNode tn
1310+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1311+ pure (tn, Nothing)
1297− let go key0 mLastNode = do
1312+ go (Just key0) mLastNode = do
1298− parent <- askParent
1313+ parent <- askParent
1299− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1314+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1315+ Nothing -> go Nothing Nothing
1300− DOM.castTo DOM.Comment node >>= \case
1316+ Just node -> DOM.castTo DOM.Comment node >>= \case
1301 Just comment -> do
1317 Just comment -> do
1302− commentText <- Node.getTextContentUnchecked comment
1318+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
1303− case T.stripPrefix (prefix <> key0) commentText of
1319+ 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.
1304 Just key -> do
1320 Just key -> do
1305 -- Replace the comment with an (invisible) text node
1321 -- Replace the comment with an (invisible) text node
1306 tn <- createTextNode doc ("" :: Text)
1322 tn <- createTextNode doc ("" :: Text)
1307 Node.replaceChild_ parent tn comment
1323 Node.replaceChild_ parent tn comment
1308− pure (tn, key)
1324+ pure (tn, Just key)
1309 Nothing -> do
1325 Nothing -> do
1310− go key0 (Just node)
1326+ go (Just key0) (Just node)
1311 Nothing -> do
1327 Nothing -> do
1312− go key0 (Just node)
1328+ go (Just key0) (Just node)
1313− switchComment = do
1329+ switchComment = do
1314− key0 <- liftIO $ readIORef key0Ref
1330+ key0 <- liftIO $ readIORef key0Ref
1315− (tn, key) <- go key0 =<< getPreviousNode
1331+ (tn, key) <- go key0 =<< getPreviousNode
1316− setPreviousNode $ Just $ toNode tn
1332+ setPreviousNode $ Just $ toNode tn
1317− liftIO $ do
1333+ liftIO $ do
1318− writeIORef textNodeRef tn
1334+ writeIORef textNodeRef tn
1319− writeIORef keyRef key
1335+ writeIORef keyRef key
1320 pure (switchComment, textNodeRef, keyRef)
1336 pure (switchComment, textNodeRef, keyRef)
1321
1337
1322{-# INLINABLE skipToReplaceStart #-}
1338{-# INLINABLE skipToReplaceStart #-}
1323−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)
1339+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 (Maybe Text))
1324−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1340+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
1325
1341
1326{-# INLINABLE skipToReplaceEnd #-}
1342{-# INLINABLE skipToReplaceEnd #-}
1327−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)
1343+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef (Maybe Text) -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
1328skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
1344skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
1329
1345
1330instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
1346instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
@@ -2250,7 +2266,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
2250 Touchend -> getTouchEvent
2266 Touchend -> getTouchEvent
2251 Touchcancel -> getTouchEvent
2267 Touchcancel -> getTouchEvent
2252 Mousewheel -> return ()
2268 Mousewheel -> return ()
2253− Wheel -> return ()
2269+ Wheel -> getWheelEvent
2254
2270
2255{-# INLINABLE defaultDomWindowEventHandler #-}
2271{-# INLINABLE defaultDomWindowEventHandler #-}
2256defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
2272defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2300,7 +2316,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
2300 Touchend -> getTouchEvent
2316 Touchend -> getTouchEvent
2301 Touchcancel -> getTouchEvent
2317 Touchcancel -> getTouchEvent
2302 Mousewheel -> return ()
2318 Mousewheel -> return ()
2303− Wheel -> return ()
2319+ Wheel -> getWheelEvent
2304
2320
2305{-# INLINABLE withIsEvent #-}
2321{-# INLINABLE withIsEvent #-}
2306withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
2322withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2618,6 +2634,26 @@ getTouchEvent = do
2618 , _touchEventResult_touches = touches
2634 , _touchEventResult_touches = touches
2619 }
2635 }
2620
2636
2637+{-# INLINABLE getWheelEvent #-}
2638+getWheelEvent :: EventM e WheelEvent WheelEventResult
2639+getWheelEvent = do
2640+ e <- event
2641+ dx :: Double <- WheelEvent.getDeltaX e
2642+ dy :: Double <- WheelEvent.getDeltaY e
2643+ dz :: Double <- WheelEvent.getDeltaZ e
2644+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2645+ return $ WheelEventResult
2646+ { _wheelEventResult_deltaX = dx
2647+ , _wheelEventResult_deltaY = dy
2648+ , _wheelEventResult_deltaZ = dz
2649+ , _wheelEventResult_deltaMode = case deltaMode of
2650+ 0 -> DeltaPixel
2651+ 1 -> DeltaLine
2652+ 2 -> DeltaPage
2653+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
2654+ _ -> error "getWheelEvent: impossible encoding"
2655+ }
2656+
2621instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
2657instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
2622 {-# INLINABLE sample #-}
2658 {-# INLINABLE sample #-}
2623 sample = lift . sample
2659 sample = lift . sample
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+12−9
@@ -55,7 +55,6 @@ import Reflex.PerformEvent.Class
55import Reflex.PostBuild.Base
55import Reflex.PostBuild.Base
56import Reflex.PostBuild.Class
56import Reflex.PostBuild.Class
57import Reflex.TriggerEvent.Class
57import Reflex.TriggerEvent.Class
58−import System.Random (randomRIO)
59
58
60data StaticDomBuilderEnv t = StaticDomBuilderEnv
59data StaticDomBuilderEnv t = StaticDomBuilderEnv
61 { _staticDomBuilderEnv_shouldEscape :: Bool
60 { _staticDomBuilderEnv_shouldEscape :: Bool
@@ -64,6 +63,7 @@ data StaticDomBuilderEnv t = StaticDomBuilderEnv
64 -- We use this to add a "selected" attribute to the appropriate "option" child element.
63 -- We use this to add a "selected" attribute to the appropriate "option" child element.
65 -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.
64 -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.
66 -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.
65 -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.
66+ , _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int
67 }
67 }
68
68
69newtype StaticDomBuilderT t m a = StaticDomBuilderT
69newtype StaticDomBuilderT t m a = StaticDomBuilderT
@@ -164,7 +164,7 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilde
164instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where
164instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where
165 runWithReplace a0 a' = do
165 runWithReplace a0 a' = do
166 e <- StaticDomBuilderT ask
166 e <- StaticDomBuilderT ask
167− key <- replaceStart
167+ key <- replaceStart e
168 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
168 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
169 o <- hold (snd result0) $ fmapCheap snd result'
169 o <- hold (snd result0) $ fmapCheap snd result'
170 StaticDomBuilderT $ modify $ (:) $ join o
170 StaticDomBuilderT $ modify $ (:) $ join o
@@ -174,10 +174,9 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m)
174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
176
176
177−-- TODO remove this?
178−replaceStart :: (DomBuilder t m, MonadIO m) => m Text
177+replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text
179−replaceStart = do
178+replaceStart env = do
180− str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')
179+ str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k))
181 let key = "-" <> T.pack str
180 let key = "-" <> T.pack str
182 _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }
181 _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }
183 pure key
182 pure key
@@ -287,7 +286,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
287 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
286 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
288 StaticDomBuilderT $ do
287 StaticDomBuilderT $ do
289 let shouldEscape = elementTag `Set.notMember` noEscapeElements
288 let shouldEscape = elementTag `Set.notMember` noEscapeElements
289+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey
290− (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing
290+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey
291 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
291 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
292 selectValue <- asks _staticDomBuilderEnv_selectValue
292 selectValue <- asks _staticDomBuilderEnv_selectValue
293 let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
293 let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
@@ -341,7 +341,9 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
341 selectElement cfg child = do
341 selectElement cfg child = do
342 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
342 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
343 (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
343 (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
344+ (a, innerHtml) <- StaticDomBuilderT $ do
345+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey
344− (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)
346+ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey
345 StaticDomBuilderT $ lift $ modify $ (:) innerHtml
347 StaticDomBuilderT $ lift $ modify $ (:) innerHtml
346 return a
348 return a
347 let wrapped = SelectElement
349 let wrapped = SelectElement
@@ -363,7 +365,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
363renderStatic w = do
365renderStatic w = do
364 runDomHost $ do
366 runDomHost $ do
365 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
367 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
368+ nextRunWithReplaceKey <- newRef 0
366− let env0 = StaticDomBuilderEnv True Nothing
369+ let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey
367 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
370 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
368 mPostBuildTrigger <- readRef postBuildTriggerRef
371 mPostBuildTrigger <- readRef postBuildTriggerRef
369 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
372 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
reflex-dom-core/src/Reflex/Dom/Class.hs+4−7
@@ -4,8 +4,7 @@ module Reflex.Dom.Class ( module Reflex.Dom.Class
4 , module Web.KeyCode
4 , module Web.KeyCode
5 ) where
5 ) where
6
6
7−import Data.Map (Map)
7+import Control.Lens
8−import qualified Data.Map as Map
9import Reflex.Class
8import Reflex.Class
10import Web.KeyCode
9import Web.KeyCode
11
10
@@ -13,11 +12,9 @@ import Foreign.JavaScript.TH
13import Reflex.PerformEvent.Class
12import Reflex.PerformEvent.Class
14import Reflex.PostBuild.Class
13import Reflex.PostBuild.Class
15
14
16−import Prelude hiding (concat, mapM, mapM_, sequence)
17−
18−-- | Alias for Data.Map.singleton
15+-- | Previously an alias for 'Data.Map.singleton', but now generalised to 'At'
19−(=:) :: k -> a -> Map k a
16+(=:) :: (At m, Monoid m) => Index m -> IxValue m -> m
20−(=:) = Map.singleton
17+k =: a = at k ?~ a $ mempty
21infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6
18infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6
22
19
23{-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
20{-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+5−25
@@ -145,7 +145,9 @@ button t = do
145
145
146--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
146--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
147-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
147-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
148−-- The returned Event of widget results occurs when the Dynamic does.
148+-- The returned Event occurs whenever the child widget is updated, which is
149+-- at post-build in addition to the times at which the input Dynamic is
150+-- updated, and its value is the result of running the widget.
149-- Note: Often, the type @a@ is an 'Event', in which case the return value is an Event-of-Events that would typically be flattened (via 'switchHold').
151-- Note: Often, the type @a@ is an 'Event', in which case the return value is an Event-of-Events that would typically be flattened (via 'switchHold').
150dyn :: (Adjustable t m, NotReady t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
152dyn :: (Adjustable t m, NotReady t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
151dyn = networkView
153dyn = networkView
@@ -269,34 +271,10 @@ dynamicAttributesToModifyAttributesWithInitial attrs0 d = do
269 return $ if Map.null p then Nothing else Just p
271 return $ if Map.null p then Nothing else Just p
270 return modificationsNeeded
272 return modificationsNeeded
271
273
272−--------------------------------------------------------------------------------
273−-- Copied and pasted from Reflex.Widget.Class
274−--------------------------------------------------------------------------------
275−
276−{-
277−schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
278−
279−elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
280−elDynHtml' elementTag html = do
281− e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
282− schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
283− performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
284− wrapElement defaultDomEventHandler e
285−
286−elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
287−elDynHtmlAttr' elementTag attrs html = do
288− e <- buildEmptyElement elementTag attrs
289− schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
290− performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
291− wrapElement defaultDomEventHandler e
292−-}
293−
294newtype Link t
274newtype Link t
295 = Link { _link_clicked :: Event t ()
275 = Link { _link_clicked :: Event t ()
296 }
276 }
297
277
298−-- | >>> linkClass "Click here" "link-class"
299−-- > <a class="link-class">Click here</a>
300linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
278linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
301linkClass s c = do
279linkClass s c = do
302 (l,_) <- elAttr' "a" ("class" =: c) $ text s
280 (l,_) <- elAttr' "a" ("class" =: c) $ text s
@@ -316,6 +294,7 @@ dtdd h w = do
316blank :: forall m. Monad m => m ()
294blank :: forall m. Monad m => m ()
317blank = return ()
295blank = return ()
318
296
297+-- TODO: Move to an example project.
319-- | A widget to display a table with static columns and dynamic rows.
298-- | A widget to display a table with static columns and dynamic rows.
320tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
299tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
321 => Text -- ^ Class applied to <table> element
300 => Text -- ^ Class applied to <table> element
@@ -332,6 +311,7 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
332 dAttrs <- rowAttrs k
311 dAttrs <- rowAttrs k
333 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
312 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
334
313
314+-- TODO: Move to an example project.
335-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
315-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
336-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
316-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
337-- the corresponding child and hides all others.
317-- the corresponding child and hides all others.
reflex-dom-core/src/Reflex/Dom/Widget/Input.hs+5−39
@@ -54,6 +54,7 @@ import qualified Text.Read as T
54import qualified GHCJS.DOM.Event as Event
54import qualified GHCJS.DOM.Event as Event
55import qualified GHCJS.DOM.HTMLInputElement as Input
55import qualified GHCJS.DOM.HTMLInputElement as Input
56
56
57+{-# DEPRECATED TextInput, _textInput_element, TextInputConfig, textInput "Use 'inputElement' directly" #-}
57data TextInput t
58data TextInput t
58 = TextInput { _textInput_value :: Dynamic t Text
59 = TextInput { _textInput_value :: Dynamic t Text
59 , _textInput_input :: Event t Text
60 , _textInput_input :: Event t Text
@@ -161,6 +162,7 @@ rangeInput (RangeInputConfig initial eSetValue dAttrs) = do
161 , _rangeInput_element = _inputElement_raw i
162 , _rangeInput_element = _inputElement_raw i
162 }
163 }
163
164
165+{-# DEPRECATED TextAreaConfig, TextArea, textArea "Use 'textAreaElement' directly" #-}
164data TextAreaConfig t
166data TextAreaConfig t
165 = TextAreaConfig { _textAreaConfig_initialValue :: Text
167 = TextAreaConfig { _textAreaConfig_initialValue :: Text
166 , _textAreaConfig_setValue :: Event t Text
168 , _textAreaConfig_setValue :: Event t Text
@@ -198,6 +200,7 @@ textArea (TextAreaConfig initial eSet attrs) = do
198 , _textArea_element = _textAreaElement_raw i
200 , _textArea_element = _textAreaElement_raw i
199 }
201 }
200
202
203+{-# DEPRECATED CheckboxConfig, Checkbox, checkbox, checkboxView, CheckboxViewEventResultType, regularToCheckboxViewEventType, CheckboxViewEventResult "Use 'inputElement' directly" #-}
201data CheckboxConfig t
204data CheckboxConfig t
202 = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool
205 = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool
203 , _checkboxConfig_attributes :: Dynamic t (Map Text Text)
206 , _checkboxConfig_attributes :: Dynamic t (Map Text Text)
@@ -287,7 +290,7 @@ regularToCheckboxViewEventType en r = case en of
287
290
288newtype CheckboxViewEventResult en = CheckboxViewEventResult { unCheckboxViewEventResult :: CheckboxViewEventResultType en }
291newtype CheckboxViewEventResult en = CheckboxViewEventResult { unCheckboxViewEventResult :: CheckboxViewEventResultType en }
289
292
290−--TODO
293+-- | Create a view only checkbox
291{-# INLINABLE checkboxView #-}
294{-# INLINABLE checkboxView #-}
292checkboxView :: 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)
295checkboxView :: 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)
293checkboxView dAttrs dValue = do
296checkboxView dAttrs dValue = do
@@ -321,6 +324,7 @@ checkboxView dAttrs dValue = do
321 i <- inputElement inputElementConfig
324 i <- inputElement inputElementConfig
322 return $ unCheckboxViewEventResult <$> select (_element_events $ _inputElement_element i) (WrapArg Click)
325 return $ unCheckboxViewEventResult <$> select (_element_events $ _inputElement_element i) (WrapArg Click)
323
326
327+{-# DEPRECATED FileInput, FileInputConfig, fileInput "Use 'inputElement' directly" #-}
324data FileInput d t
328data FileInput d t
325 = FileInput { _fileInput_value :: Dynamic t [File]
329 = FileInput { _fileInput_value :: Dynamic t [File]
326 , _fileInput_element :: RawInputElement d
330 , _fileInput_element :: RawInputElement d
@@ -681,41 +685,3 @@ instance HasValue (Dropdown t k) where
681instance HasValue (Checkbox t) where
685instance HasValue (Checkbox t) where
682 type Value (Checkbox t) = Dynamic t Bool
686 type Value (Checkbox t) = Dynamic t Bool
683 value = _checkbox_value
687 value = _checkbox_value
684−
685−{-
686−type family Controller sm t a where
687− Controller Edit t a = (a, Event t a) -- Initial value and setter
688− Controller View t a = Dynamic t a -- Value (always)
689−
690−type family Output sm t a where
691− Output Edit t a = Dynamic t a -- Value (always)
692− Output View t a = Event t a -- Requested changes
693−
694−data CheckboxConfig sm t
695− = CheckboxConfig { _checkbox_input :: Controller sm t Bool
696− , _checkbox_attributes :: Attributes
697− }
698−
699−instance Reflex t => Default (CheckboxConfig Edit t) where
700− def = CheckboxConfig (False, never) mempty
701−
702−data Checkbox sm t
703− = Checkbox { _checkbox_output :: Output sm t Bool
704− }
705−
706−data StateMode = Edit | View
707−
708−--TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode
709−data StateModeWitness (sm :: StateMode) where
710− EditWitness :: StateModeWitness Edit
711− ViewWitness :: StateModeWitness View
712−
713−class HasStateModeWitness (sm :: StateMode) where
714− stateModeWitness :: StateModeWitness sm
715−
716−instance HasStateModeWitness Edit where
717− stateModeWitness = EditWitness
718−
719−instance HasStateModeWitness View where
720− stateModeWitness = ViewWitness
721−-}
reflex-dom-core/src/Reflex/Dom/Xhr.hs+8−6
@@ -159,6 +159,8 @@ import Data.Aeson.Text
159import Data.Aeson.Encode
159import Data.Aeson.Encode
160#endif
160#endif
161import qualified Data.ByteString.Lazy as BL
161import qualified Data.ByteString.Lazy as BL
162+import Data.CaseInsensitive (CI)
163+import qualified Data.CaseInsensitive as CI
162import Data.Default
164import Data.Default
163import qualified Data.List as L
165import qualified Data.List as L
164import Data.Map (Map)
166import Data.Map (Map)
@@ -198,12 +200,12 @@ data XhrResponse
198 , _xhrResponse_statusText :: Text
200 , _xhrResponse_statusText :: Text
199 , _xhrResponse_response :: Maybe XhrResponseBody
201 , _xhrResponse_response :: Maybe XhrResponseBody
200 , _xhrResponse_responseText :: Maybe Text
202 , _xhrResponse_responseText :: Maybe Text
201− , _xhrResponse_headers :: Map Text Text
203+ , _xhrResponse_headers :: Map (CI Text) Text
202 }
204 }
203 deriving (Typeable)
205 deriving (Typeable)
204
206
205data XhrResponseHeaders =
207data XhrResponseHeaders =
206− OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response
208+ OnlyHeaders (Set.Set (CI Text)) -- ^ Parse a subset of headers from the XHR Response
207 | AllHeaders -- ^ Parse all headers from the XHR Response
209 | AllHeaders -- ^ Parse all headers from the XHR Response
208 deriving (Show, Read, Eq, Ord, Typeable)
210 deriving (Show, Read, Eq, Ord, Typeable)
209
211
@@ -275,7 +277,7 @@ newXMLHttpRequestWithError req cb = do
275 AllHeaders -> parseAllHeadersString <$>
277 AllHeaders -> parseAllHeadersString <$>
276 xmlHttpRequestGetAllResponseHeaders xhr
278 xmlHttpRequestGetAllResponseHeaders xhr
277 OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
279 OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
278− (Map.fromSet id xs)
280+ (Map.fromSet CI.original xs)
279 _ <- liftJSM $ cb $ Right
281 _ <- liftJSM $ cb $ Right
280 XhrResponse { _xhrResponse_status = status
282 XhrResponse { _xhrResponse_status = status
281 , _xhrResponse_statusText = statusText
283 , _xhrResponse_statusText = statusText
@@ -288,10 +290,10 @@ newXMLHttpRequestWithError req cb = do
288 return ()
290 return ()
289 return xhr
291 return xhr
290
292
291−parseAllHeadersString :: Text -> Map Text Text
293+parseAllHeadersString :: Text -> Map (CI Text) Text
292parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
294parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
293 L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
295 L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
294− where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
296+ where stripBoth (txt1, txt2) = (CI.mk $ T.strip txt1, T.strip $ T.drop 1 txt2)
295
297
296newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
298newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
297newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
299newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
@@ -444,7 +446,7 @@ xhrResponse_responseText :: Lens' XhrResponse (Maybe Text)
444xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4
446xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4
445{-# INLINE xhrResponse_responseText #-}
447{-# INLINE xhrResponse_responseText #-}
446
448
447−xhrResponse_headers :: Lens' XhrResponse (Map Text Text)
449+xhrResponse_headers :: Lens' XhrResponse (Map (CI Text) Text)
448xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5
450xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5
449{-# INLINE xhrResponse_headers #-}
451{-# INLINE xhrResponse_headers #-}
450
452
reflex-dom-core/test/hydration.hs+94−26
@@ -1,13 +1,9 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
7−{-# LANGUAGE CPP #-}
8{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
@@ -15,13 +11,19 @@
15{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE RecursiveDo #-}
12{-# LANGUAGE RecursiveDo #-}
17{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TupleSections #-}
20{-# LANGUAGE TypeApplications #-}
17{-# LANGUAGE TypeApplications #-}
21{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeFamilies #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+
21+{-# OPTIONS_GHC -fno-warn-orphans #-}
22
22
23import Prelude hiding (fail)
23import Prelude hiding (fail)
24import Control.Concurrent
24import Control.Concurrent
25+import qualified Control.Concurrent.Async as Async
26+import Control.Lens.Operators
25import Control.Monad hiding (fail)
27import Control.Monad hiding (fail)
26import Control.Monad.Catch
28import Control.Monad.Catch
27import Control.Monad.Fail
29import Control.Monad.Fail
@@ -31,7 +33,7 @@ import Control.Monad.Ref
31import Data.Constraint.Extras
33import Data.Constraint.Extras
32import Data.Constraint.Extras.TH
34import Data.Constraint.Extras.TH
33import Data.Dependent.Map (DMap)
35import Data.Dependent.Map (DMap)
34−import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
36+import Data.Dependent.Sum (DSum(..), (==>))
35import Data.Functor.Identity
37import Data.Functor.Identity
36import Data.Functor.Misc
38import Data.Functor.Misc
37import Data.GADT.Compare.TH
39import Data.GADT.Compare.TH
@@ -62,7 +64,6 @@ import Test.Hspec (xit)
62import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
64import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
63import qualified Test.Hspec.WebDriver as WD
65import qualified Test.Hspec.WebDriver as WD
64import Test.WebDriver (WD(..))
66import Test.WebDriver (WD(..))
65−import Test.WebDriver.Exceptions (ServerError(..))
66
67
67import qualified Data.ByteString.Lazy as LBS
68import qualified Data.ByteString.Lazy as LBS
68import qualified Data.Dependent.Map as DMap
69import qualified Data.Dependent.Map as DMap
@@ -78,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD
78import Test.Util.ChromeFlags
79import Test.Util.ChromeFlags
79import Test.Util.UnshareNetwork
80import Test.Util.UnshareNetwork
80
81
82+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
83+deriving instance MonadMask WD
84+
81chromium :: FilePath
85chromium :: FilePath
82chromium = $(staticWhich "chromium")
86chromium = $(staticWhich "chromium")
83
87
@@ -770,6 +774,15 @@ tests withDebugging wdConfig caps _selenium = do
770 prerender_ (pure ()) (liftIO $ trigger "Client")
774 prerender_ (pure ()) (liftIO $ trigger "Client")
771 textNode $ TextNodeConfig "Initial" $ Just e
775 textNode $ TextNodeConfig "Initial" $ Just e
772
776
777+ describe "namespaces" $ session' $ do
778+ it "dyn can be nested in namespaced widget" $ runWD $ do
779+ testWidget (pure ()) (checkTextInTag "svg" "one") $ do
780+ let svgRootCfg = def
781+ & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
782+ & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
783+ void $ element "svg" svgRootCfg $ do
784+ dyn_ $ text "one" <$ pure ()
785+
773 describe "runWithReplace" $ session' $ do
786 describe "runWithReplace" $ session' $ do
774 it "works" $ runWD $ do
787 it "works" $ runWD $ do
775 replaceChan :: Chan Text <- liftIO newChan
788 replaceChan :: Chan Text <- liftIO newChan
@@ -914,6 +927,58 @@ tests withDebugging wdConfig caps _selenium = do
914 , el "span" . text <$> replace
927 , el "span" . text <$> replace
915 ]
928 ]
916
929
930+ let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
931+ it "removes bracketing comments" $ runWD $ do
932+ replaceChan :: Chan () <- liftIO newChan
933+ let
934+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
935+ check () = do
936+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
937+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
938+ checkInnerHtml "div" "before|<p>inner2</p>|after"
939+ testWidget' preSwitchover check $ do
940+ replace <- triggerEventWithChan replaceChan
941+ el "div" $ do
942+ text "before|"
943+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
944+ text "|after"
945+ it "ignores extra ending bracketing comment" $ runWD $ do
946+ replaceChan :: Chan () <- liftIO newChan
947+ let
948+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
949+ check () = do
950+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
951+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
952+ checkInnerHtml "div" "before|inner2|after"
953+ testWidget' preSwitchover check $ do
954+ replace <- triggerEventWithChan replaceChan
955+ el "div" $ do
956+ text "before|"
957+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
958+ text "|after"
959+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
960+ it "ignores missing ending bracketing comments" $ runWD $ do
961+ replaceChan :: Chan () <- liftIO newChan
962+ let
963+ preSwitchover = do
964+ checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
965+ divEl <- findElemWithRetry (WD.ByTag "div")
966+ let wrongHtml = "<!--replace-start-0-->inner1"
967+ actualHtml :: String <- WD.executeJS
968+ [WD.JSArg divEl, WD.JSArg wrongHtml]
969+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
970+ actualHtml `shouldBe` wrongHtml
971+ check () = do
972+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
973+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
974+ checkInnerHtml "div" "before|<p>inner2</p>|after"
975+ testWidget' preSwitchover check $ do
976+ replace <- triggerEventWithChan replaceChan
977+ el "div" $ do
978+ text "before|"
979+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
980+ text "|after"
981+
917 describe "traverseDMapWithKeyWithAdjust" $ session' $ do
982 describe "traverseDMapWithKeyWithAdjust" $ session' $ do
918 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
983 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
919 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
984 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
@@ -1305,8 +1370,8 @@ withRetry a = wait 300
1305 where wait :: Int -> WD a
1370 where wait :: Int -> WD a
1306 wait 0 = a
1371 wait 0 = a
1307 wait n = try a >>= \case
1372 wait n = try a >>= \case
1308− Left (_ :: SomeException) -> do
1373+ Left (e :: SomeException) -> do
1309− liftIO $ threadDelay 100000
1374+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1310 wait $ n - 1
1375 wait $ n - 1
1311 Right v -> return v
1376 Right v -> return v
1312
1377
@@ -1388,23 +1453,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1388 ]
1453 ]
1389 -- hSilence to get rid of ConnectionClosed logs
1454 -- hSilence to get rid of ConnectionClosed logs
1390 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1455 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1391− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1456+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1392− jsaddleTid <- liftIO jsaddleWarp
1457+ withAsync' jsaddleWarp $ do
1393− putStrLnDebug "taking waitJSaddle"
1458+ putStrLnDebug "taking waitJSaddle"
1394− liftIO $ takeMVar waitJSaddle
1459+ liftIO $ takeMVar waitJSaddle
1395− putStrLnDebug "opening page"
1460+ putStrLnDebug "opening page"
1396− WD.openPage $ "http://localhost:" <> show jsaddlePort
1461+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1397− putStrLnDebug "running beforeJS"
1462+ putStrLnDebug "running beforeJS"
1398− a <- beforeJS
1463+ a <- beforeJS
1399− putStrLnDebug "putting waitBeforeJS"
1464+ putStrLnDebug "putting waitBeforeJS"
1400− liftIO $ putMVar waitBeforeJS ()
1465+ liftIO $ putMVar waitBeforeJS ()
1401− putStrLnDebug "taking waitUntilSwitchover"
1466+ putStrLnDebug "taking waitUntilSwitchover"
1402− liftIO $ takeMVar waitUntilSwitchover
1467+ liftIO $ takeMVar waitUntilSwitchover
1403− putStrLnDebug "running afterSwitchover"
1468+ putStrLnDebug "running afterSwitchover"
1404− b <- afterSwitchover a
1469+ afterSwitchover a
1405− putStrLnDebug "killing jsaddle thread"
1470+
1406− liftIO $ killThread jsaddleTid
1471+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1407− return b
1472+withAsync' f g = bracket
1473+ (liftIO $ Async.async f)
1474+ (liftIO . Async.uninterruptibleCancel)
1475+ (const g)
1408
1476
1409data Key2 a where
1477data Key2 a where
1410 Key2_Int :: Int -> Key2 Int
1478 Key2_Int :: Int -> Key2 Int
reflex-dom/ChangeLog.md+15−1
@@ -1,6 +1,19 @@
1# Revision history for reflex-dom
1# Revision history for reflex-dom
2
2
3−## 0.5.1
3+## Unreleased
4+
5+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
6+
7+## 0.5.3
8+
9+* On Android, enable prompting the user for geolocation
10+ permissions on demand by default. See
11+ https://developer.android.com/reference/android/webkit/WebChromeClient.html#onGeolocationPermissionsShowPrompt(java.lang.String,%20android.webkit.GeolocationPermissions.Callback)
12+ for details.
13+
14+ * Add `< 0.7` upper bound for reflex
15+
16+## 0.5.2
4
17
5* The default jsaddle backend on macOS when built from nix
18* The default jsaddle backend on macOS when built from nix
6 is now jsaddle-wkwebview, matching the behaviour of cabal
19 is now jsaddle-wkwebview, matching the behaviour of cabal
@@ -9,4 +22,5 @@
9## 0.5
22## 0.5
10
23
11* Re-export new hydration widget "mainWidget" functions.
24* Re-export new hydration widget "mainWidget" functions.
25+
12* The use-warp flag now properly takes precedence on macOS.
26* The use-warp flag now properly takes precedence on macOS.
reflex-dom/java/org/reflexfrp/reflexdom/MainWidget.java+6
@@ -8,6 +8,7 @@ import android.util.Log;
8import android.view.ViewGroup.LayoutParams;
8import android.view.ViewGroup.LayoutParams;
9import android.view.Window;
9import android.view.Window;
10import android.webkit.CookieManager;
10import android.webkit.CookieManager;
11+import android.webkit.GeolocationPermissions;
11import android.webkit.JavascriptInterface;
12import android.webkit.JavascriptInterface;
12import android.webkit.MimeTypeMap;
13import android.webkit.MimeTypeMap;
13import android.webkit.PermissionRequest;
14import android.webkit.PermissionRequest;
@@ -122,6 +123,11 @@ public class MainWidget {
122 public Bitmap getDefaultVideoPoster() {
123 public Bitmap getDefaultVideoPoster() {
123 return Bitmap.createBitmap(10, 10, Bitmap.Config.ARGB_8888);
124 return Bitmap.createBitmap(10, 10, Bitmap.Config.ARGB_8888);
124 }
125 }
126+
127+ @Override
128+ public void onGeolocationPermissionsShowPrompt(String origin, GeolocationPermissions.Callback callback) {
129+ callback.invoke(origin, true, false);
130+ }
125 });
131 });
126
132
127 wv.addJavascriptInterface(new JSaddleCallbacks(jsaddleCallbacks), "jsaddle");
133 wv.addJavascriptInterface(new JSaddleCallbacks(jsaddleCallbacks), "jsaddle");
reflex-dom/reflex-dom.cabal+11−6
@@ -1,5 +1,5 @@
1Name: reflex-dom
1Name: reflex-dom
2−Version: 0.5.2.0
2+Version: 0.5.3
3Synopsis: Functional Reactive Web Apps with Reflex
3Synopsis: Functional Reactive Web Apps with Reflex
4Description:
4Description:
5 Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine.
5 Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine.
@@ -59,8 +59,8 @@ library
59 build-depends:
59 build-depends:
60 base >= 4.7 && < 4.13,
60 base >= 4.7 && < 4.13,
61 bytestring == 0.10.*,
61 bytestring == 0.10.*,
62− reflex >= 0.6.2,
62+ reflex >= 0.6.2 && < 0.8,
63− reflex-dom-core >=0.5.2 && <0.6,
63+ reflex-dom-core >=0.5.2 && < 0.6,
64 text == 1.2.*
64 text == 1.2.*
65 if !impl(ghcjs)
65 if !impl(ghcjs)
66 if flag(use-warp) && (os(linux) || os(osx))
66 if flag(use-warp) && (os(linux) || os(osx))
@@ -74,13 +74,18 @@ library
74 jsaddle,
74 jsaddle,
75 jsaddle-wkwebview
75 jsaddle-wkwebview
76 else
76 else
77− if flag(webkit2gtk)
77+ if arch(wasm32)
78 build-depends:
78 build-depends:
79− jsaddle-webkit2gtk
79+ jsaddle,
80+ jsaddle-wasm
80 else
81 else
81− if !os(android)
82+ if flag(webkit2gtk)
82 build-depends:
83 build-depends:
83 jsaddle-webkit2gtk
84 jsaddle-webkit2gtk
85+ else
86+ if !os(android)
87+ build-depends:
88+ jsaddle-webkit2gtk
84
89
85 exposed-modules:
90 exposed-modules:
86 Reflex.Dom
91 Reflex.Dom
reflex-dom/src/Reflex/Dom/Internal.hs+5
@@ -80,6 +80,11 @@ run jsm = do
80 startMainWidget a startPage jsm
80 startMainWidget a startPage jsm
81 }
81 }
82 forever $ threadDelay 1000000000
82 forever $ threadDelay 1000000000
83+#elif defined(wasm32_HOST_ARCH)
84+import qualified Language.Javascript.JSaddle.Wasm as Wasm (run)
85+import Language.Javascript.JSaddle (JSM)
86+run :: JSM () -> IO ()
87+run = Wasm.run 0
83#else
88#else
84import Language.Javascript.JSaddle.WebKitGTK (run)
89import Language.Javascript.JSaddle.WebKitGTK (run)
85#endif
90#endif
release.nix+27−8
@@ -17,16 +17,35 @@ let
17 ] ++ lib.optionals (reflex-platform.iosSupport) [
17 ] ++ lib.optionals (reflex-platform.iosSupport) [
18 "ghcIosAarch64"
18 "ghcIosAarch64"
19 ];
19 ];
20− hsPkgs = lib.genAttrs compilers (ghc: let
20+ compilerPkgs = lib.genAttrs compilers (ghc: let
21− ghc' = reflex-platform.${ghc}.override {
21+ reflex-platform = reflex-platform-fun {
22− overrides = self: super: import ./. self;
22+ inherit system;
23+ haskellOverlays = [
24+ # Use this package's source for reflex
25+ (self: super: {
26+ _dep = super._dep // {
27+ reflex-dom = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
28+ "release.nix"
29+ ".git"
30+ "dist"
31+ ])) ./.;
32+ };
33+ })
34+ ];
23 };
35 };
36+ all = {
37+ inherit (reflex-platform.${ghc})
38+ reflex-dom-core
39+ reflex-dom
40+ ;
41+ };
24− in {
42+ in all // {
25− inherit (ghc') reflex-dom reflex-dom-core;
43+ cache = reflex-platform.pinBuildInputs "reflex-${system}-${ghc}"
44+ (builtins.attrValues all);
26 });
45 });
27− in hsPkgs // {
46+ in compilerPkgs // {
28− cache = reflex-platform.pinBuildInputs "reflex-dom-${system}"
47+ cache = reflex-platform.pinBuildInputs "reflex-${system}"
29− (lib.concatLists (map builtins.attrValues (builtins.attrValues hsPkgs)));
48+ (map (a: a.cache) (builtins.attrValues compilerPkgs));
30 });
49 });
31
50
32 metaCache = native-reflex-platform.pinBuildInputs "reflex-dom-everywhere"
51 metaCache = native-reflex-platform.pinBuildInputs "reflex-dom-everywhere"