c62edff · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'develop' into ts-generalised-singleton

c62edffElliot Cameron7 years ago

cabal.projectnew file+1

compare with develop

unifiedsplit

@@ -0,0 +1 @@

1+packages: reflex-dom-core, reflex-dom

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

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

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "develop",

4+ "branch": "master",

5− "rev": "e7b76dd552a10916c7d8702c11292dac4f4299ea",

5+ "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",

6− "sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh"

6+ "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"

reflex-dom-core/ChangeLog.md+35

@@ -1,5 +1,28 @@

1# Revision history for reflex-dom-core

3+## Unreleased

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

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+

3## 0.5.3

26## 0.5.3

5* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:

28* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:

@@ -21,24 +44,36 @@

22 * Add `< 0.7` upper bound for reflex

45 * Add `< 0.7` upper bound for reflex

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+

24## 0.5.2

50## 0.5.2

26* 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+

27* Update version bounds of base, containers, and stm

54* Update version bounds of base, containers, and stm

55+

28* 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+

29* Reintroduce "data-ssr": elements without this attribute are skipped during

58* Reintroduce "data-ssr": elements without this attribute are skipped during

30 hydration.

59 hydration.

60+

31* 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+

32* 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+

33* 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

35## 0.5.1

67## 0.5.1

37* 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+

38* Removed "data-ssr" attributes from statically rendered output.

71* Removed "data-ssr" attributes from statically rendered output.

40## 0.5

73## 0.5

42* 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+

43* 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+

44* 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+8−6

@@ -48,11 +48,12 @@ library

48 hs-source-dirs: src

49 build-depends:

50 aeson >= 0.8 && < 1.5,

51− base >= 4.7 && < 4.13,

51+ base >= 4.7 && < 4.14,

52 bifunctors >= 4.2 && < 6,

53 bimap >= 0.3 && < 0.4,

54 blaze-builder,

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,

@@ -69,11 +70,11 @@ library

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 && < 0.7,

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

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

639-- * Convenience functions

640

641−class HasDomEvent t target eventName where

641+class HasDomEvent t target eventName | target -> t where

642 type DomEventType target eventName :: *

643 domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)

644

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

@@ -159,7 +159,17 @@ type family EventResultType (en :: EventTag) :: * where

159 EventResultType 'TouchmoveTag = TouchEventResult

160 EventResultType 'TouchendTag = TouchEventResult

161 EventResultType 'TouchcancelTag = TouchEventResult

162− EventResultType 'WheelTag = ()

162+ EventResultType 'WheelTag = WheelEventResult

163+

164+data DeltaMode = DeltaPixel | DeltaLine | DeltaPage

165+ deriving (Show, Read, Eq, Ord, Bounded, Enum)

166+

167+data WheelEventResult = WheelEventResult

168+ { _wheelEventResult_deltaX :: Double

169+ , _wheelEventResult_deltaY :: Double

170+ , _wheelEventResult_deltaZ :: Double

171+ , _wheelEventResult_deltaMode :: DeltaMode

172+ } deriving (Show, Read, Eq, Ord)

163

173

164data TouchEventResult = TouchEventResult

174data TouchEventResult = TouchEventResult

165 { _touchEventResult_altKey :: Bool

175 { _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

22import Reflex

23import Reflex.Dom.Builder.Class

24−import Reflex.Dom.Builder.Immediate (HasDocument (..))

24+import Reflex.Dom.Builder.Immediate (HasDocument (..), hydratableAttribute)

25import Reflex.Host.Class

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

29-- added by external scripts.

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

63makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m

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 }

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

108 , Window (..)

109 , wrapWindow

110+ -- * Attributes for controlling hydration

111+ , hydratableAttribute

112+ , skipHydrationAttribute

110 -- * Internal

113 -- * Internal

111 , traverseDMapWithKeyWithAdjust'

114 , traverseDMapWithKeyWithAdjust'

112 , hoistTraverseWithKeyWithAdjust

115 , hoistTraverseWithKeyWithAdjust

@@ -137,11 +140,12 @@ 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.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

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

144−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)

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

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

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

146import GHCJS.DOM.KeyboardEvent as KeyboardEvent

150import GHCJS.DOM.KeyboardEvent as KeyboardEvent

147import GHCJS.DOM.MouseEvent

151import GHCJS.DOM.MouseEvent

@@ -192,6 +196,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent

192import qualified GHCJS.DOM.TouchList as TouchList

196import qualified GHCJS.DOM.TouchList as TouchList

193import qualified GHCJS.DOM.Types as DOM

197import qualified GHCJS.DOM.Types as DOM

194import qualified GHCJS.DOM.Window as Window

198import qualified GHCJS.DOM.Window as Window

199+import qualified GHCJS.DOM.WheelEvent as WheelEvent

195import qualified Reflex.Patch.DMap as PatchDMap

200import qualified Reflex.Patch.DMap as PatchDMap

196import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

201import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

197import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

202import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

@@ -318,8 +323,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati

318addHydrationStepWithSetup setup f = getHydrationMode >>= \case

323addHydrationStepWithSetup setup f = getHydrationMode >>= \case

319 HydrationMode_Immediate -> pure ()

324 HydrationMode_Immediate -> pure ()

320 HydrationMode_Hydrating -> do

325 HydrationMode_Hydrating -> do

321− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

326+ s <- lift setup

322− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover

323 addHydrationStep (f s)

327 addHydrationStep (f s)

324

328

325-- | Add a hydration step

329-- | Add a hydration step

@@ -743,6 +747,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case

743 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)

747 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)

744 #-}

748 #-}

745

749

750+-- | An attribute which causes hydration to skip over an element completely.

751+skipHydrationAttribute :: IsString s => s

752+skipHydrationAttribute = "data-hydration-skip"

753+

754+-- | An attribute which signals that an element should be hydrated.

755+hydratableAttribute :: IsString s => s

756+hydratableAttribute = "data-ssr"

757+

746{-# INLINE hydrateElement #-}

758{-# INLINE hydrateElement #-}

747hydrateElement

759hydrateElement

748 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)

760 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)

@@ -764,18 +776,15 @@ hydrateElement elementTag cfg child = do

764 }

776 }

765 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'

777 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'

766 wrapResult <- liftIO newEmptyMVar

778 wrapResult <- liftIO newEmptyMVar

767− let skipAttr = "data-hydration-skip" :: DOM.JSString

779+ let -- Determine if we should skip an element. We currently skip elements for

768− ssrAttr = "data-ssr" :: DOM.JSString

780+ -- two reasons:

781+ -- 1) it was not produced by a static builder which supports hydration

782+ -- 2) it is explicitly marked to be skipped

769 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool

783 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool

770− shouldSkip e = case cfg ^. namespace of

784+ shouldSkip e = do

771− Nothing -> do

772− skip <- hasAttribute e skipAttr

785+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)

773− ssr <- hasAttribute e ssrAttr

786+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)

774− pure $ skip || not ssr

775− Just ns -> do

776− skip <- hasAttributeNS e (Just ns) skipAttr

777− ssr <- hasAttributeNS e (Just ns) ssrAttr

778− pure $ skip || not ssr

787+ pure $ skip || not hydratable

779 childDom <- liftIO $ readIORef childDelayedRef

788 childDom <- liftIO $ readIORef childDelayedRef

780 let rawCfg = extractRawElementConfig cfg

789 let rawCfg = extractRawElementConfig cfg

781 doc <- askDocument

790 doc <- askDocument

@@ -791,7 +800,7 @@ hydrateElement elementTag cfg child = do

791 Just node -> DOM.castTo DOM.Element node >>= \case

800 Just node -> DOM.castTo DOM.Element node >>= \case

792 Nothing -> go (Just node) -- this node is not an element, skip

801 Nothing -> go (Just node) -- this node is not an element, skip

793 Just e -> shouldSkip e >>= \case

802 Just e -> shouldSkip e >>= \case

794− True -> go (Just node) -- this element is explicitly marked for being skipped by hydration

803+ True -> go (Just node) -- this element should be skipped by hydration

795 False -> do

804 False -> do

796 t <- Element.getTagName e

805 t <- Element.getTagName e

797 -- TODO: check attributes?

806 -- TODO: check attributes?

@@ -1277,8 +1286,8 @@ hydrateComment doc t mSetContents = do

1277skipToAndReplaceComment

1286skipToAndReplaceComment

1278 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)

1287 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)

1279 => Text

1288 => Text

1280− -> IORef Text

1289+ -> IORef (Maybe Text)

1281− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

1290+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))

1282skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1291skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1283 HydrationMode_Immediate -> do

1292 HydrationMode_Immediate -> do

1284 -- If we're in immediate mode, we don't try to replace an existing comment,

1293 -- If we're in immediate mode, we don't try to replace an existing comment,

@@ -1286,43 +1295,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1286 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

1295 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

1287 append $ toNode t

1296 append $ toNode t

1288 textNodeRef <- liftIO $ newIORef t

1297 textNodeRef <- liftIO $ newIORef t

1289− keyRef <- liftIO $ newIORef ""

1298+ keyRef <- liftIO $ newIORef Nothing

1290 pure (pure (), textNodeRef, keyRef)

1299 pure (pure (), textNodeRef, keyRef)

1291 HydrationMode_Hydrating -> do

1300 HydrationMode_Hydrating -> do

1292 doc <- askDocument

1301 doc <- askDocument

1293 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"

1302 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"

1294 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"

1303 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"

1304+ let

1305+ go Nothing _ = do

1306+ tn <- createTextNode doc ("" :: Text)

1307+ insertAfterPreviousNode tn

1308+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }

1309+ pure (tn, Nothing)

1295− let go key0 mLastNode = do

1310+ go (Just key0) mLastNode = do

1296− parent <- askParent

1311+ parent <- askParent

1297− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

1312+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case

1313+ Nothing -> go Nothing Nothing

1298− DOM.castTo DOM.Comment node >>= \case

1314+ Just node -> DOM.castTo DOM.Comment node >>= \case

1299 Just comment -> do

1315 Just comment -> do

1300− commentText <- Node.getTextContentUnchecked comment

1316+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment

1301− case T.stripPrefix (prefix <> key0) commentText of

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

1302 Just key -> do

1318 Just key -> do

1303 -- Replace the comment with an (invisible) text node

1319 -- Replace the comment with an (invisible) text node

1304 tn <- createTextNode doc ("" :: Text)

1320 tn <- createTextNode doc ("" :: Text)

1305 Node.replaceChild_ parent tn comment

1321 Node.replaceChild_ parent tn comment

1306− pure (tn, key)

1322+ pure (tn, Just key)

1307 Nothing -> do

1323 Nothing -> do

1308− go key0 (Just node)

1324+ go (Just key0) (Just node)

1309 Nothing -> do

1325 Nothing -> do

1310− go key0 (Just node)

1326+ go (Just key0) (Just node)

1311− switchComment = do

1327+ switchComment = do

1312− key0 <- liftIO $ readIORef key0Ref

1328+ key0 <- liftIO $ readIORef key0Ref

1313− (tn, key) <- go key0 =<< getPreviousNode

1329+ (tn, key) <- go key0 =<< getPreviousNode

1314− setPreviousNode $ Just $ toNode tn

1330+ setPreviousNode $ Just $ toNode tn

1315− liftIO $ do

1331+ liftIO $ do

1316− writeIORef textNodeRef tn

1332+ writeIORef textNodeRef tn

1317− writeIORef keyRef key

1333+ writeIORef keyRef key

1318 pure (switchComment, textNodeRef, keyRef)

1334 pure (switchComment, textNodeRef, keyRef)

1319

1335

1320{-# INLINABLE skipToReplaceStart #-}

1336{-# INLINABLE skipToReplaceStart #-}

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

1337+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))

1322−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")

1338+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.

1323

1339

1324{-# INLINABLE skipToReplaceEnd #-}

1340{-# INLINABLE skipToReplaceEnd #-}

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

1341+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)

1326skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

1342skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

1327

1343

1328instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

1344instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

@@ -2248,7 +2264,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of

2248 Touchend -> getTouchEvent

2264 Touchend -> getTouchEvent

2249 Touchcancel -> getTouchEvent

2265 Touchcancel -> getTouchEvent

2250 Mousewheel -> return ()

2266 Mousewheel -> return ()

2251− Wheel -> return ()

2267+ Wheel -> getWheelEvent

2252

2268

2253{-# INLINABLE defaultDomWindowEventHandler #-}

2269{-# INLINABLE defaultDomWindowEventHandler #-}

2254defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))

2270defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))

@@ -2298,7 +2314,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of

2298 Touchend -> getTouchEvent

2314 Touchend -> getTouchEvent

2299 Touchcancel -> getTouchEvent

2315 Touchcancel -> getTouchEvent

2300 Mousewheel -> return ()

2316 Mousewheel -> return ()

2301− Wheel -> return ()

2317+ Wheel -> getWheelEvent

2302

2318

2303{-# INLINABLE withIsEvent #-}

2319{-# INLINABLE withIsEvent #-}

2304withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r

2320withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r

@@ -2607,6 +2623,26 @@ getTouchEvent = do

2607 , _touchEventResult_touches = touches

2623 , _touchEventResult_touches = touches

2608 }

2624 }

2609

2625

2626+{-# INLINABLE getWheelEvent #-}

2627+getWheelEvent :: EventM e WheelEvent WheelEventResult

2628+getWheelEvent = do

2629+ e <- event

2630+ dx :: Double <- WheelEvent.getDeltaX e

2631+ dy :: Double <- WheelEvent.getDeltaY e

2632+ dz :: Double <- WheelEvent.getDeltaZ e

2633+ deltaMode :: Word <- WheelEvent.getDeltaMode e

2634+ return $ WheelEventResult

2635+ { _wheelEventResult_deltaX = dx

2636+ , _wheelEventResult_deltaY = dy

2637+ , _wheelEventResult_deltaZ = dz

2638+ , _wheelEventResult_deltaMode = case deltaMode of

2639+ 0 -> DeltaPixel

2640+ 1 -> DeltaLine

2641+ 2 -> DeltaPage

2642+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode

2643+ _ -> error "getWheelEvent: impossible encoding"

2644+ }

2645+

2610instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where

2646instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where

2611 {-# INLINABLE sample #-}

2647 {-# INLINABLE sample #-}

2612 sample = lift . sample

2648 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

56import Reflex.PostBuild.Class

57import Reflex.TriggerEvent.Class

58−import System.Random (randomRIO)

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 }

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

165 runWithReplace a0 a' = do

166 e <- StaticDomBuilderT ask

167− key <- replaceStart

167+ key <- replaceStart e

168 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

169 o <- hold (snd result0) $ fmapCheap snd result'

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

175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

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)

292 selectValue <- asks _staticDomBuilderEnv_selectValue

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

342 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)

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/Widget/Basic.hs−7

@@ -138,7 +138,6 @@ dynComment t = do

138display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

139display = dynText . fmap (T.pack . show)

140

141−{-# DEPRECATED button "Use 'elAttr'' in combination with 'domEvent' instead" #-}

142button :: DomBuilder t m => Text -> m (Event t ())

141button :: DomBuilder t m => Text -> m (Event t ())

143button t = do

142button t = do

144 (e, _) <- element "button" def $ text t

143 (e, _) <- element "button" def $ text t

@@ -272,25 +271,21 @@ dynamicAttributesToModifyAttributesWithInitial attrs0 d = do

272 return $ if Map.null p then Nothing else Just p

271 return $ if Map.null p then Nothing else Just p

273 return modificationsNeeded

272 return modificationsNeeded

274

273

275−{-# DEPRECATED Link "Will be removed when 'linkClass' and 'link' are removed. Follow those functions' deprecation instructions." #-}

276newtype Link t

274newtype Link t

277 = Link { _link_clicked :: Event t ()

275 = Link { _link_clicked :: Event t ()

278 }

276 }

279

277

280−{-# DEPRECATED linkClass "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-}

281linkClass :: DomBuilder t m => Text -> Text -> m (Link t)

278linkClass :: DomBuilder t m => Text -> Text -> m (Link t)

282linkClass s c = do

279linkClass s c = do

283 (l,_) <- elAttr' "a" ("class" =: c) $ text s

280 (l,_) <- elAttr' "a" ("class" =: c) $ text s

284 return $ Link $ domEvent Click l

281 return $ Link $ domEvent Click l

285

282

286−{-# DEPRECATED link "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-}

287link :: DomBuilder t m => Text -> m (Link t)

283link :: DomBuilder t m => Text -> m (Link t)

288link s = linkClass s ""

284link s = linkClass s ""

289

285

290divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a

286divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a

291divClass = elClass "div"

287divClass = elClass "div"

292

288

293−{-# DEPRECATED dtdd "Use an application specific widget generating function" #-}

294dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a

289dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a

295dtdd h w = do

290dtdd h w = do

296 el "dt" $ text h

291 el "dt" $ text h

@@ -301,7 +296,6 @@ blank = return ()

301

296

302-- TODO: Move to an example project.

297-- TODO: Move to an example project.

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

304−{-# DEPRECATED tableDynAttr "Use an application specific widget generating function" #-}

305tableDynAttr :: 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)

306 => Text -- ^ Class applied to <table> element

300 => Text -- ^ Class applied to <table> element

307 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

301 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

@@ -321,7 +315,6 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo

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

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

323-- the corresponding child and hides all others.

317-- the corresponding child and hides all others.

324−{-# DEPRECATED tabDisplay "Use an application specific widget generating function" #-}

325tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)

318tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)

326 => Text -- ^ Class applied to <ul> element

319 => Text -- ^ Class applied to <ul> element

327 -> Text -- ^ Class applied to currently active <li> element

320 -> Text -- ^ Class applied to currently active <li> element

reflex-dom-core/src/Reflex/Dom/Xhr.hs+8−6

@@ -159,6 +159,8 @@ import Data.Aeson.Text

159import Data.Aeson.Encode

160#endif

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 #-}

23import Prelude hiding (fail)

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

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

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

@@ -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|inner1|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|inner1|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|inner1|after"

965+ divEl <- findElemWithRetry (WD.ByTag "div")

966+ let wrongHtml = "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+5

@@ -1,5 +1,9 @@

1# Revision history for reflex-dom

3+## Unreleased

5+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.

3## 0.5.3

7## 0.5.3

5* On Android, enable prompting the user for geolocation

9* On Android, enable prompting the user for geolocation

@@ -18,4 +22,5 @@

18## 0.5

22## 0.5

20* Re-export new hydration widget "mainWidget" functions.

24* Re-export new hydration widget "mainWidget" functions.

25+

21* The use-warp flag now properly takes precedence on macOS.

26* The use-warp flag now properly takes precedence on macOS.

reflex-dom/reflex-dom.cabal+1−1

@@ -59,7 +59,7 @@ library

59 build-depends:

60 base >= 4.7 && < 4.13,

61 bytestring == 0.10.*,

62− reflex >= 0.6.2 && < 0.7,

62+ reflex >= 0.6.2 && < 0.8,

63 reflex-dom-core >=0.5.2 && < 0.6,

64 text == 1.2.*

65 if !impl(ghcjs)