reflex-dom-core 0.5.3 → 0.6.0.0
raw patch · 13 files changed
+335/−141 lines, 13 filesdep +asyncdep +case-insensitivedep ~basedep ~blaze-builderdep ~dependent-sumnew-uploader
Dependencies added: async, case-insensitive
Dependency ranges changed: base, blaze-builder, dependent-sum, hashable, primitive, random, reflex, semialign, semigroups, template-haskell
Files
- ChangeLog.md +46/−15
- reflex-dom-core.cabal +24/−16
- src/Reflex/Dom/Builder/Class.hs +1/−1
- src/Reflex/Dom/Builder/Class/Events.hs +13/−2
- src/Reflex/Dom/Builder/Hydratable.hs +4/−4
- src/Reflex/Dom/Builder/Immediate.hs +88/−41
- src/Reflex/Dom/Builder/Static.hs +12/−9
- src/Reflex/Dom/Class.hs +4/−7
- src/Reflex/Dom/Widget/Basic.hs +0/−7
- src/Reflex/Dom/Widget/Input.hs +4/−1
- src/Reflex/Dom/Widget/Resize.hs +4/−4
- src/Reflex/Dom/Xhr.hs +8/−6
- test/hydration.hs +127/−28
ChangeLog.md view
@@ -1,44 +1,75 @@ # Revision history for reflex-dom-core +## 0.6.0.0++* ([#375](https://github.com/reflex-frp/reflex-dom/pull/375)) **(Breaking change)** Expose resized dimensions from `resizeDetector`, `resizeDetectorWithStyle`, and `resizeDetectorWithAttrs` from `Reflex.Dom.Widget.Resize`.+* ([#374](https://github.com/reflex-frp/reflex-dom/pull/374)) **(Breaking change)** Provide text clipboard data as value of `Paste` event.+* ([#348](https://github.com/reflex-frp/reflex-dom/pull/348)) **(Breaking change)** Make XHR response headers case insensitive by changing `_xhrResponse_headers :: Map Text Text` to `_xhrResponse_headers :: Map (CI Text) Text`.+* ([#225](https://github.com/reflex-frp/reflex-dom/pull/225)) **(Breaking change)** Add a functional dependency to `HasDomEvent`.+* ([#342](https://github.com/reflex-frp/reflex-dom/issues/342)) **(Breaking change)** The mouse wheel event is now a `WheelEventResult` rather than `()`. This provides information about the wheel's motion beyond the fact that it merely moved.+* ([#353](https://github.com/reflex-frp/reflex-dom/pull/353)) Support GHC 8.8.+* ([#358](https://github.com/reflex-frp/reflex-dom/pull/358)) Fix attribute support for explicitly namespaced elements.+* ([#363](https://github.com/reflex-frp/reflex-dom/pull/363)) Remove deprecation warnings for the following widgets in+ `Reflex.Dom.Widget.Basic`:+ * `Link`+ * `button`+ * `dtdd`+ * `linkClass`+ * `link`+ * `tabDisplay`+ * `tableDynAttr`+* ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)) Fix bug in hydration causing the JavaScript to crash when dealing with unexpected HTML.+* ([#310](https://github.com/reflex-frp/reflex-dom/issues/310)) Fix the static rendering of which dropdown value is selected.+* ([#364](https://github.com/reflex-frp/reflex-dom/pull/364)) Export attributes used for controlling hydration at the element level:+ * "data-ssr" is now available as `Reflex.Dom.Builder.Immediate.hydratableAttribute`.+ * "data-hydration-skip" is now available as `Reflex.Dom.Builder.Immediate.skipHydrationAttribute`.+* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.+ ## 0.5.3 * Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:-- * `Link`- * `button`- * `dtdd`- * `linkClass`- * `link`- * `tabDisplay`- * `tableDynAttr`+ * `Link`+ * `button`+ * `dtdd`+ * `linkClass`+ * `link`+ * `tabDisplay`+ * `tableDynAttr` And in `Reflex.Dom.Widget.Input`:-- * `TextInput`- * `TextAreaConfig`- * `CheckboxConfig`- * `FileInput`-- * Add `< 0.7` upper bound for reflex+ * `TextInput`+ * `TextAreaConfig`+ * `CheckboxConfig`+ * `FileInput`+* Add `< 0.7` upper bound for `reflex`. ## 0.5.2 * Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).+ * Update version bounds of base, containers, and stm+ * Update to use the newly split `these`/`semialign` packages. To use the pre-split `these` package, set the `split-these` flag to false.+ * Reintroduce "data-ssr": elements without this attribute are skipped during hydration.+ * Fix an issue in the hydration tests that prevented the test from finding the chromium executable+ * Relax constraints on `dyn` and `widgetHold` to match the ones in `networkView` and `networkHold` respectively+ * Fix prerender for RequesterT so that it doesn't accidentally discard a request that is made at the same moment as getPostBuild's Event fires ## 0.5.1 * Added support for marking elements with a "data-skip-hydration" attribute, which will cause hydration to ignore and skip over them.+ * Removed "data-ssr" attributes from statically rendered output. ## 0.5 * Add HydrationDomBuilderT to support hydration of statically rendered DOM nodes. See the note at the top of Reflex.Dom.Builder.Immediate.+ * As a result of the hydration changes, the Prerender class has changed, the type of `prerender` has changed and it is now a class method.+ * Add the Reflex.Dom.Xhr.FormData module to make posting formdata over xhr more convenient.
reflex-dom-core.cabal view
@@ -1,7 +1,14 @@+cabal-version: 1.24 Name: reflex-dom-core-Version: 0.5.3+Version: 0.6.0.0 Synopsis: Functional Reactive Web Apps with Reflex-Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine+Description:+ Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.+ .+ The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the+ correct set of dependencies for each target platform (GHCJS, WebKitGTK, WASM, mobile, etc.).+ Libraries should depend on @reflex-dom-core@ and executables will usually depend on @reflex-dom@.+ All of @reflex-dom-core@'s modules are re-exported by @reflex-dom@. License: BSD3 License-file: LICENSE Author: Ryan Trinkle@@ -9,7 +16,6 @@ Stability: Experimental Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface Build-type: Simple-Cabal-version: >=1.9.2 -- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs src-ghcjs/Foreign/JavaScript/Internal/Utils.hs@@ -48,11 +54,12 @@ hs-source-dirs: src build-depends: aeson >= 0.8 && < 1.5,- base >= 4.7 && < 4.13,+ base >= 4.7 && < 4.14, bifunctors >= 4.2 && < 6, bimap >= 0.3 && < 0.4,- blaze-builder,+ blaze-builder >= 0.4.1 && < 0.5, bytestring == 0.10.*,+ case-insensitive < 1.3, containers >= 0.6 && < 0.7, constraints >= 0.9 && < 0.12, contravariant >= 1.4 && < 1.6,@@ -69,11 +76,11 @@ lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, mtl >= 2.1 && < 2.3,- primitive >= 0.5 && < 0.7,- random,+ primitive >= 0.5 && < 0.8,+ random >= 1.1 && < 1.2, ref-tf == 0.4.*,- reflex >= 0.6.2 && < 0.7,- semigroups >= 0.16 && < 0.19,+ reflex >= 0.6.2 && < 0.8,+ semigroups >= 0.16 && < 0.20, stm >= 2.4 && < 2.6, text == 1.2.*, transformers >= 0.3 && < 0.6,@@ -84,7 +91,7 @@ hs-source-dirs: src-ghcjs build-depends: ghcjs-base,- hashable == 1.2.*+ hashable >= 1.2 && < 1.4 else hs-source-dirs: src-ghc if !os(windows)@@ -92,7 +99,7 @@ if flag(split-these) build-depends:- semialign >= 1 && < 1.1,+ semialign >= 1 && < 1.2, these >= 1 && < 1.1 else build-depends:@@ -132,6 +139,7 @@ Reflex.Dom.Xhr.ResponseType Reflex.Dom.Xhr.Exception + default-language: Haskell98 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively ghc-prof-options: -fprof-auto @@ -146,26 +154,24 @@ if flag(use-template-haskell) build-depends:- dependent-sum >= 0.6, dependent-sum-template >= 0.1 && < 0.2,- template-haskell+ template-haskell >= 2.12.0 && < 2.16 other-extensions: TemplateHaskell cpp-options: -DUSE_TEMPLATE_HASKELL other-modules: Reflex.Dom.Builder.Class.TH- else- build-depends:- dependent-sum == 0.6.* test-suite hlint build-depends: base, hlint hs-source-dirs: test main-is: hlint.hs type: exitcode-stdio-1.0+ default-language: Haskell98 test-suite hydration build-depends: base , aeson+ , async , bytestring , chrome-test-utils , constraints@@ -207,6 +213,7 @@ ghc-prof-options: -fprof-auto -optP-DPROFILING main-is: hydration.hs type: exitcode-stdio-1.0+ default-language: Haskell98 if !os(linux) || !arch(x86_64) || flag(profile-reflex) buildable: False @@ -226,6 +233,7 @@ ghc-prof-options: -fprof-auto -optP-DPROFILING main-is: gc.hs type: exitcode-stdio-1.0+ default-language: Haskell98 if !os(linux) || !arch(x86_64) buildable: False
src/Reflex/Dom/Builder/Class.hs view
@@ -638,7 +638,7 @@ -- * Convenience functions -class HasDomEvent t target eventName where+class HasDomEvent t target eventName | target -> t where type DomEventType target eventName :: * domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)
src/Reflex/Dom/Builder/Class/Events.hs view
@@ -14,6 +14,7 @@ import Data.GADT.Compare (GOrdering(..), (:~:)(..), GEq(..), GCompare(..)) #endif+import Data.Text (Text) data EventTag = AbortTag@@ -151,7 +152,7 @@ EventResultType 'BeforecopyTag = () EventResultType 'CopyTag = () EventResultType 'BeforepasteTag = ()- EventResultType 'PasteTag = ()+ EventResultType 'PasteTag = Maybe Text EventResultType 'ResetTag = () EventResultType 'SearchTag = () EventResultType 'SelectstartTag = ()@@ -159,7 +160,17 @@ EventResultType 'TouchmoveTag = TouchEventResult EventResultType 'TouchendTag = TouchEventResult EventResultType 'TouchcancelTag = TouchEventResult- EventResultType 'WheelTag = ()+ EventResultType 'WheelTag = WheelEventResult++data DeltaMode = DeltaPixel | DeltaLine | DeltaPage+ deriving (Show, Read, Eq, Ord, Bounded, Enum)++data WheelEventResult = WheelEventResult+ { _wheelEventResult_deltaX :: Double+ , _wheelEventResult_deltaY :: Double+ , _wheelEventResult_deltaZ :: Double+ , _wheelEventResult_deltaMode :: DeltaMode+ } deriving (Show, Read, Eq, Ord) data TouchEventResult = TouchEventResult { _touchEventResult_altKey :: Bool
src/Reflex/Dom/Builder/Hydratable.hs view
@@ -21,10 +21,10 @@ #endif import Reflex import Reflex.Dom.Builder.Class-import Reflex.Dom.Builder.Immediate (HasDocument (..))+import Reflex.Dom.Builder.Immediate (HasDocument (..), hydratableAttribute) import Reflex.Host.Class --- | A DomBuilder transformer that adds "data-ssr" to all elements such that the+-- | A DomBuilder transformer that adds an attribute to all elements such that the -- hydration builder knows which bits of DOM were added by us, and which were -- added by external scripts. newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)@@ -62,8 +62,8 @@ makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m makeHydratable cfg = cfg- { _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg- , _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg+ { _elementConfig_initialAttributes = Map.insert hydratableAttribute "" $ _elementConfig_initialAttributes cfg+ , _elementConfig_modifyAttributes = fmap (Map.delete hydratableAttribute) <$> _elementConfig_modifyAttributes cfg } instance PostBuild t m => PostBuild t (HydratableT m) where
src/Reflex/Dom/Builder/Immediate.hs view
@@ -107,6 +107,9 @@ , WindowConfig (..) , Window (..) , wrapWindow+ -- * Attributes for controlling hydration+ , hydratableAttribute+ , skipHydrationAttribute -- * Internal , traverseDMapWithKeyWithAdjust' , hoistTraverseWithKeyWithAdjust@@ -137,11 +140,13 @@ import Data.Maybe import Data.Monoid ((<>)) import Data.Some (Some(..))+import Data.String (IsString) import Data.Text (Text) import Foreign.JavaScript.Internal.Utils import Foreign.JavaScript.TH+import GHCJS.DOM.ClipboardEvent as ClipboardEvent import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)-import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute) import GHCJS.DOM.EventM (EventM, event, on) import GHCJS.DOM.KeyboardEvent as KeyboardEvent import GHCJS.DOM.MouseEvent@@ -175,6 +180,7 @@ import qualified Data.Map as Map import qualified Data.Text as T import qualified GHCJS.DOM as DOM+import qualified GHCJS.DOM.DataTransfer as DataTransfer import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events import qualified GHCJS.DOM.DocumentOrShadowRoot as Document import qualified GHCJS.DOM.Element as Element@@ -192,6 +198,7 @@ import qualified GHCJS.DOM.TouchList as TouchList import qualified GHCJS.DOM.Types as DOM import qualified GHCJS.DOM.Window as Window+import qualified GHCJS.DOM.WheelEvent as WheelEvent import qualified Reflex.Patch.DMap as PatchDMap import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove import qualified Reflex.Patch.MapWithMove as PatchMapWithMove@@ -318,8 +325,7 @@ addHydrationStepWithSetup setup f = getHydrationMode >>= \case HydrationMode_Immediate -> pure () HydrationMode_Hydrating -> do- switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover- (s, _) <- lift $ runWithReplace setup $ return () <$ switchover+ s <- lift setup addHydrationStep (f s) -- | Add a hydration step@@ -743,6 +749,14 @@ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a) #-} +-- | An attribute which causes hydration to skip over an element completely.+skipHydrationAttribute :: IsString s => s+skipHydrationAttribute = "data-hydration-skip"++-- | An attribute which signals that an element should be hydrated.+hydratableAttribute :: IsString s => s+hydratableAttribute = "data-ssr"+ {-# INLINE hydrateElement #-} hydrateElement :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)@@ -764,18 +778,15 @@ } result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env' wrapResult <- liftIO newEmptyMVar- let skipAttr = "data-hydration-skip" :: DOM.JSString- ssrAttr = "data-ssr" :: DOM.JSString+ let -- Determine if we should skip an element. We currently skip elements for+ -- two reasons:+ -- 1) it was not produced by a static builder which supports hydration+ -- 2) it is explicitly marked to be skipped shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool- shouldSkip e = case cfg ^. namespace of- Nothing -> do- skip <- hasAttribute e skipAttr- ssr <- hasAttribute e ssrAttr- pure $ skip || not ssr- Just ns -> do- skip <- hasAttributeNS e (Just ns) skipAttr- ssr <- hasAttributeNS e (Just ns) ssrAttr- pure $ skip || not ssr+ shouldSkip e = do+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)+ pure $ skip || not hydratable childDom <- liftIO $ readIORef childDelayedRef let rawCfg = extractRawElementConfig cfg doc <- askDocument@@ -791,7 +802,7 @@ Just node -> DOM.castTo DOM.Element node >>= \case Nothing -> go (Just node) -- this node is not an element, skip Just e -> shouldSkip e >>= \case- True -> go (Just node) -- this element is explicitly marked for being skipped by hydration+ True -> go (Just node) -- this element should be skipped by hydration False -> do t <- Element.getTagName e -- TODO: check attributes?@@ -1277,8 +1288,8 @@ skipToAndReplaceComment :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Text- -> IORef Text- -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)+ -> IORef (Maybe Text)+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text)) skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case HydrationMode_Immediate -> do -- If we're in immediate mode, we don't try to replace an existing comment,@@ -1286,43 +1297,50 @@ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing append $ toNode t textNodeRef <- liftIO $ newIORef t- keyRef <- liftIO $ newIORef ""+ keyRef <- liftIO $ newIORef Nothing pure (pure (), textNodeRef, keyRef) HydrationMode_Hydrating -> do doc <- askDocument textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized" keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"- let go key0 mLastNode = do- parent <- askParent- node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode- DOM.castTo DOM.Comment node >>= \case+ let+ go Nothing _ = do+ tn <- createTextNode doc ("" :: Text)+ insertAfterPreviousNode tn+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }+ pure (tn, Nothing)+ go (Just key0) mLastNode = do+ parent <- askParent+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case+ Nothing -> go Nothing Nothing+ Just node -> DOM.castTo DOM.Comment node >>= \case Just comment -> do- commentText <- Node.getTextContentUnchecked comment- case T.stripPrefix (prefix <> key0) commentText of+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment+ case T.stripPrefix (prefix <> key0) commentText of -- 'key0' may be @""@ in which case we're just finding the actual key; TODO: Don't be clever. Just key -> do -- Replace the comment with an (invisible) text node tn <- createTextNode doc ("" :: Text) Node.replaceChild_ parent tn comment- pure (tn, key)+ pure (tn, Just key) Nothing -> do- go key0 (Just node)+ go (Just key0) (Just node) Nothing -> do- go key0 (Just node)- switchComment = do- key0 <- liftIO $ readIORef key0Ref- (tn, key) <- go key0 =<< getPreviousNode- setPreviousNode $ Just $ toNode tn- liftIO $ do- writeIORef textNodeRef tn- writeIORef keyRef key+ go (Just key0) (Just node)+ switchComment = do+ key0 <- liftIO $ readIORef key0Ref+ (tn, key) <- go key0 =<< getPreviousNode+ setPreviousNode $ Just $ toNode tn+ liftIO $ do+ writeIORef textNodeRef tn+ writeIORef keyRef key pure (switchComment, textNodeRef, keyRef) {-# INLINABLE skipToReplaceStart #-}-skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)-skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")+skipToReplaceStart :: (MonadJSM m, 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))+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work. {-# INLINABLE skipToReplaceEnd #-}-skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)+skipToReplaceEnd :: (MonadJSM m, 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) skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where@@ -2239,7 +2257,7 @@ Beforecopy -> return () Copy -> return () Beforepaste -> return ()- Paste -> return ()+ Paste -> getPasteData Reset -> return () Search -> return () Selectstart -> return ()@@ -2248,7 +2266,7 @@ Touchend -> getTouchEvent Touchcancel -> getTouchEvent Mousewheel -> return ()- Wheel -> return ()+ Wheel -> getWheelEvent {-# INLINABLE defaultDomWindowEventHandler #-} defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))@@ -2289,7 +2307,7 @@ Beforecopy -> return () Copy -> return () Beforepaste -> return ()- Paste -> return ()+ Paste -> getPasteData Reset -> return () Search -> return () Selectstart -> return ()@@ -2298,7 +2316,7 @@ Touchend -> getTouchEvent Touchcancel -> getTouchEvent Mousewheel -> return ()- Wheel -> return ()+ Wheel -> getWheelEvent {-# INLINABLE withIsEvent #-} withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r@@ -2566,6 +2584,15 @@ e <- event bisequence (getClientX e, getClientY e) +{-# INLINABLE getPasteData #-}+getPasteData :: EventM e ClipboardEvent (Maybe Text)+getPasteData = do+ e <- event+ mdt <- ClipboardEvent.getClipboardData e+ case mdt of+ Nothing -> return Nothing+ Just dt -> Just <$> DataTransfer.getData dt ("text" :: Text)+ {-# INLINABLE getTouchEvent #-} getTouchEvent :: EventM e TouchEvent TouchEventResult getTouchEvent = do@@ -2605,6 +2632,26 @@ , _touchEventResult_shiftKey = shiftKey , _touchEventResult_targetTouches = targetTouches , _touchEventResult_touches = touches+ }++{-# INLINABLE getWheelEvent #-}+getWheelEvent :: EventM e WheelEvent WheelEventResult+getWheelEvent = do+ e <- event+ dx :: Double <- WheelEvent.getDeltaX e+ dy :: Double <- WheelEvent.getDeltaY e+ dz :: Double <- WheelEvent.getDeltaZ e+ deltaMode :: Word <- WheelEvent.getDeltaMode e+ return $ WheelEventResult+ { _wheelEventResult_deltaX = dx+ , _wheelEventResult_deltaY = dy+ , _wheelEventResult_deltaZ = dz+ , _wheelEventResult_deltaMode = case deltaMode of+ 0 -> DeltaPixel+ 1 -> DeltaLine+ 2 -> DeltaPage+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode+ _ -> error "getWheelEvent: impossible encoding" } instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
src/Reflex/Dom/Builder/Static.hs view
@@ -55,7 +55,6 @@ import Reflex.PostBuild.Base import Reflex.PostBuild.Class import Reflex.TriggerEvent.Class-import System.Random (randomRIO) data StaticDomBuilderEnv t = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool@@ -64,6 +63,7 @@ -- We use this to add a "selected" attribute to the appropriate "option" child element. -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing. -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.+ , _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int } newtype StaticDomBuilderT t m a = StaticDomBuilderT@@ -164,7 +164,7 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where runWithReplace a0 a' = do e <- StaticDomBuilderT ask- key <- replaceStart+ key <- replaceStart e (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a') o <- hold (snd result0) $ fmapCheap snd result' StaticDomBuilderT $ modify $ (:) $ join o@@ -174,10 +174,9 @@ traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove --- TODO remove this?-replaceStart :: (DomBuilder t m, MonadIO m) => m Text-replaceStart = do- str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')+replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text+replaceStart env = do+ str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k)) let key = "-" <> T.pack str _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key } pure key@@ -287,7 +286,8 @@ es <- newFanEventWithTrigger $ \_ _ -> return (return ()) StaticDomBuilderT $ do let shouldEscape = elementTag `Set.notMember` noEscapeElements- (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes) selectValue <- asks _staticDomBuilderEnv_selectValue let addSelectedAttr attrs sel = case Map.lookup "value" attrs of@@ -341,7 +341,9 @@ selectElement cfg child = do v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue) (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do- (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)+ (a, innerHtml) <- StaticDomBuilderT $ do+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey+ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey StaticDomBuilderT $ lift $ modify $ (:) innerHtml return a let wrapped = SelectElement@@ -363,7 +365,8 @@ renderStatic w = do runDomHost $ do (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef- let env0 = StaticDomBuilderEnv True Nothing+ nextRunWithReplaceKey <- newRef 0+ let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0 mPostBuildTrigger <- readRef postBuildTriggerRef forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
src/Reflex/Dom/Class.hs view
@@ -4,8 +4,7 @@ , module Web.KeyCode ) where -import Data.Map (Map)-import qualified Data.Map as Map+import Control.Lens import Reflex.Class import Web.KeyCode @@ -13,11 +12,9 @@ import Reflex.PerformEvent.Class import Reflex.PostBuild.Class -import Prelude hiding (concat, mapM, mapM_, sequence)---- | Alias for Data.Map.singleton-(=:) :: k -> a -> Map k a-(=:) = Map.singleton+-- | Previously an alias for 'Data.Map.singleton', but now generalised to 'At'+(=:) :: (At m, Monoid m) => Index m -> IxValue m -> m+k =: a = at k ?~ a $ mempty infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6 {-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
src/Reflex/Dom/Widget/Basic.hs view
@@ -138,7 +138,6 @@ display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m () display = dynText . fmap (T.pack . show) -{-# DEPRECATED button "Use 'elAttr'' in combination with 'domEvent' instead" #-} button :: DomBuilder t m => Text -> m (Event t ()) button t = do (e, _) <- element "button" def $ text t@@ -272,25 +271,21 @@ return $ if Map.null p then Nothing else Just p return modificationsNeeded -{-# DEPRECATED Link "Will be removed when 'linkClass' and 'link' are removed. Follow those functions' deprecation instructions." #-} newtype Link t = Link { _link_clicked :: Event t () } -{-# DEPRECATED linkClass "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-} linkClass :: DomBuilder t m => Text -> Text -> m (Link t) linkClass s c = do (l,_) <- elAttr' "a" ("class" =: c) $ text s return $ Link $ domEvent Click l -{-# DEPRECATED link "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-} link :: DomBuilder t m => Text -> m (Link t) link s = linkClass s "" divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a divClass = elClass "div" -{-# DEPRECATED dtdd "Use an application specific widget generating function" #-} dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a dtdd h w = do el "dt" $ text h@@ -301,7 +296,6 @@ -- TODO: Move to an example project. -- | A widget to display a table with static columns and dynamic rows.-{-# DEPRECATED tableDynAttr "Use an application specific widget generating function" #-} tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Text -- ^ Class applied to <table> element -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)@@ -321,7 +315,6 @@ -- | A widget to construct a tabbed view that shows only one of its child widgets at a time. -- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays -- the corresponding child and hides all others.-{-# DEPRECATED tabDisplay "Use an application specific widget generating function" #-} tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k) => Text -- ^ Class applied to <ul> element -> Text -- ^ Class applied to currently active <li> element
src/Reflex/Dom/Widget/Input.hs view
@@ -437,9 +437,12 @@ let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs) modifyAttrs <- dynamicAttributesToModifyAttributes attrs+ postBuild <- getPostBuild+ let setSelection = attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys $+ leftmost [setK, k0 <$ postBuild] let cfg = def & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs- & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)+ & selectElementConfig_setValue .~ fmap (T.pack . show) setSelection (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey elDynAttr "option" optionAttrs $ dynText v
src/Reflex/Dom/Widget/Resize.hs view
@@ -37,19 +37,19 @@ -- This function can cause strange scrollbars to appear in some circumstances. -- These can be hidden with pseudo selectors, for example, in webkit browsers: -- .wrapper *::-webkit-scrollbar { width: 0px; background: transparent; }-resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (Maybe Double, Maybe Double), a) resizeDetector = resizeDetectorWithStyle "" resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute. -> m a -- ^ The embedded widget- -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString) resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute. -> m a -- ^ The embedded widget- -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget+ -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget resizeDetectorWithAttrs attrs w = do let childStyle = "position: absolute; left: 0; top: 0;" containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"@@ -91,4 +91,4 @@ size0 <- performEvent $ fmap (const $ liftJSM reset) pb rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll] dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]- return (fmapMaybe void resize, w')+ return (updated dimensions, w')
src/Reflex/Dom/Xhr.hs view
@@ -159,6 +159,8 @@ import Data.Aeson.Encode #endif import qualified Data.ByteString.Lazy as BL+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI import Data.Default import qualified Data.List as L import Data.Map (Map)@@ -198,12 +200,12 @@ , _xhrResponse_statusText :: Text , _xhrResponse_response :: Maybe XhrResponseBody , _xhrResponse_responseText :: Maybe Text- , _xhrResponse_headers :: Map Text Text+ , _xhrResponse_headers :: Map (CI Text) Text } deriving (Typeable) data XhrResponseHeaders =- OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response+ OnlyHeaders (Set.Set (CI Text)) -- ^ Parse a subset of headers from the XHR Response | AllHeaders -- ^ Parse all headers from the XHR Response deriving (Show, Read, Eq, Ord, Typeable) @@ -275,7 +277,7 @@ AllHeaders -> parseAllHeadersString <$> xmlHttpRequestGetAllResponseHeaders xhr OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)- (Map.fromSet id xs)+ (Map.fromSet CI.original xs) _ <- liftJSM $ cb $ Right XhrResponse { _xhrResponse_status = status , _xhrResponse_statusText = statusText@@ -288,10 +290,10 @@ return () return xhr -parseAllHeadersString :: Text -> Map Text Text+parseAllHeadersString :: Text -> Map (CI Text) Text parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $ L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s- where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)+ where stripBoth (txt1, txt2) = (CI.mk $ T.strip txt1, T.strip $ T.drop 1 txt2) newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb@@ -444,7 +446,7 @@ xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4 {-# INLINE xhrResponse_responseText #-} -xhrResponse_headers :: Lens' XhrResponse (Map Text Text)+xhrResponse_headers :: Lens' XhrResponse (Map (CI Text) Text) xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5 {-# INLINE xhrResponse_headers #-}
test/hydration.hs view
@@ -1,13 +1,9 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -15,13 +11,19 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ import Prelude hiding (fail) import Control.Concurrent+import qualified Control.Concurrent.Async as Async+import Control.Lens.Operators import Control.Monad hiding (fail) import Control.Monad.Catch import Control.Monad.Fail@@ -31,12 +33,13 @@ import Data.Constraint.Extras import Data.Constraint.Extras.TH import Data.Dependent.Map (DMap)-import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))+import Data.Dependent.Sum (DSum(..), (==>)) import Data.Functor.Identity import Data.Functor.Misc import Data.GADT.Compare.TH import Data.GADT.Show.TH import Data.IORef (IORef)+import Data.List (sort) import Data.Maybe import Data.Proxy import Data.Text (Text)@@ -47,6 +50,7 @@ import Network.Wai import Network.WebSockets import Reflex.Dom.Core+import Reflex.Dom.Widget.Input (dropdown) import Reflex.Patch.DMapWithMove import System.Directory import System.Environment@@ -55,14 +59,13 @@ import System.IO.Temp import System.Process import System.Which (staticWhich)-import qualified Test.HUnit as HUnit (assertEqual, assertFailure)+import qualified Test.HUnit as HUnit import qualified Test.Hspec as H import qualified Test.Hspec.Core.Spec as H import Test.Hspec (xit) import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD) import qualified Test.Hspec.WebDriver as WD import Test.WebDriver (WD(..))-import Test.WebDriver.Exceptions (ServerError(..)) import qualified Data.ByteString.Lazy as LBS import qualified Data.Dependent.Map as DMap@@ -78,6 +81,9 @@ import Test.Util.ChromeFlags import Test.Util.UnshareNetwork +-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167+deriving instance MonadMask WD+ chromium :: FilePath chromium = $(staticWhich "chromium") @@ -93,11 +99,14 @@ writeRef r = WD . writeRef r assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()-assertEqual a b = liftIO . HUnit.assertEqual a b+assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b assertFailure :: MonadIO m => String -> m () assertFailure = liftIO . HUnit.assertFailure +assertBool :: (MonadIO m) => String -> Bool -> m ()+assertBool msg bool = liftIO $ HUnit.assertBool msg bool+ chromeConfig :: Text -> [Text] -> WD.WDConfig chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig @@ -770,6 +779,15 @@ prerender_ (pure ()) (liftIO $ trigger "Client") textNode $ TextNodeConfig "Initial" $ Just e + describe "namespaces" $ session' $ do+ it "dyn can be nested in namespaced widget" $ runWD $ do+ testWidget (pure ()) (checkTextInTag "svg" "one") $ do+ let svgRootCfg = def+ & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")+ & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))+ void $ element "svg" svgRootCfg $ do+ dyn_ $ text "one" <$ pure ()+ describe "runWithReplace" $ session' $ do it "works" $ runWD $ do replaceChan :: Chan Text <- liftIO newChan@@ -914,6 +932,58 @@ , el "span" . text <$> replace ] + let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)+ it "removes bracketing comments" $ runWD $ do+ replaceChan :: Chan () <- liftIO newChan+ let+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"+ check () = do+ liftIO $ writeChan replaceChan () -- trigger creation of p tag+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created+ checkInnerHtml "div" "before|<p>inner2</p>|after"+ testWidget' preSwitchover check $ do+ replace <- triggerEventWithChan replaceChan+ el "div" $ do+ text "before|"+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace+ text "|after"+ it "ignores extra ending bracketing comment" $ runWD $ do+ replaceChan :: Chan () <- liftIO newChan+ let+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"+ check () = do+ liftIO $ writeChan replaceChan () -- trigger creation of p tag+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created+ checkInnerHtml "div" "before|inner2|after"+ testWidget' preSwitchover check $ do+ replace <- triggerEventWithChan replaceChan+ el "div" $ do+ text "before|"+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace+ text "|after"+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test+ it "ignores missing ending bracketing comments" $ runWD $ do+ replaceChan :: Chan () <- liftIO newChan+ let+ preSwitchover = do+ checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"+ divEl <- findElemWithRetry (WD.ByTag "div")+ let wrongHtml = "<!--replace-start-0-->inner1"+ actualHtml :: String <- WD.executeJS+ [WD.JSArg divEl, WD.JSArg wrongHtml]+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"+ actualHtml `shouldBe` wrongHtml+ check () = do+ liftIO $ writeChan replaceChan () -- trigger creation of p tag+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created+ checkInnerHtml "div" "before|<p>inner2</p>|after"+ testWidget' preSwitchover check $ do+ replace <- triggerEventWithChan replaceChan+ el "div" $ do+ text "before|"+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace+ text "|after"+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a) widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do@@ -1230,6 +1300,29 @@ el "ol" $ text "inner" text "after" + -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.+ -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.+ -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.+ describe "dropdown" $ session' $ do+ let doTest expectedOpts (initialValue :: Text) = do+ let doCheck = do+ es <- findElemsWithRetry $ WD.ByTag "option"+ opts <- mapM fetchElement es+ assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)+ testWidget doCheck doCheck $ do+ void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def+ fetchElement e = do+ val <- WD.attr e "value"+ sel <- WD.attr e "selected"+ return (fromMaybe "" val, isJust sel)+ -- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)+ -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.+ xit "statically renders initial values (on aa)" $ runWD $ do+ doTest [("0",True),("1",False)] "aa"+ -- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well+ xit "statically renders initial values (on bb)" $ runWD $ do+ doTest [("0",False),("1",True)] "bb"+ data Selenium = Selenium { _selenium_portNumber :: PortNumber , _selenium_stopServer :: IO ()@@ -1297,6 +1390,9 @@ findElemWithRetry :: Selector -> WD WD.Element findElemWithRetry = withRetry . WD.findElem +findElemsWithRetry :: Selector -> WD [WD.Element]+findElemsWithRetry = withRetry . WD.findElems+ getBody :: WD WD.Element getBody = WD.findElem $ WD.ByTag "body" @@ -1305,8 +1401,8 @@ where wait :: Int -> WD a wait 0 = a wait n = try a >>= \case- Left (_ :: SomeException) -> do- liftIO $ threadDelay 100000+ Left (e :: SomeException) -> do+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000 wait $ n - 1 Right v -> return v @@ -1388,23 +1484,26 @@ ] -- hSilence to get rid of ConnectionClosed logs silenceIfDebug = if withDebugging then id else hSilence [stderr]- jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application- jsaddleTid <- liftIO jsaddleWarp- putStrLnDebug "taking waitJSaddle"- liftIO $ takeMVar waitJSaddle- putStrLnDebug "opening page"- WD.openPage $ "http://localhost:" <> show jsaddlePort- putStrLnDebug "running beforeJS"- a <- beforeJS- putStrLnDebug "putting waitBeforeJS"- liftIO $ putMVar waitBeforeJS ()- putStrLnDebug "taking waitUntilSwitchover"- liftIO $ takeMVar waitUntilSwitchover- putStrLnDebug "running afterSwitchover"- b <- afterSwitchover a- putStrLnDebug "killing jsaddle thread"- liftIO $ killThread jsaddleTid- return b+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application+ withAsync' jsaddleWarp $ do+ putStrLnDebug "taking waitJSaddle"+ liftIO $ takeMVar waitJSaddle+ putStrLnDebug "opening page"+ WD.openPage $ "http://localhost:" <> show jsaddlePort+ putStrLnDebug "running beforeJS"+ a <- beforeJS+ putStrLnDebug "putting waitBeforeJS"+ liftIO $ putMVar waitBeforeJS ()+ putStrLnDebug "taking waitUntilSwitchover"+ liftIO $ takeMVar waitUntilSwitchover+ putStrLnDebug "running afterSwitchover"+ afterSwitchover a++withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b+withAsync' f g = bracket+ (liftIO $ Async.async f)+ (liftIO . Async.uninterruptibleCancel)+ (const g) data Key2 a where Key2_Int :: Int -> Key2 Int