diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/reflex-dom-core.cabal b/reflex-dom-core.cabal --- a/reflex-dom-core.cabal +++ b/reflex-dom-core.cabal @@ -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: . + . + 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 diff --git a/src/Reflex/Dom/Builder/Class.hs b/src/Reflex/Dom/Builder/Class.hs --- a/src/Reflex/Dom/Builder/Class.hs +++ b/src/Reflex/Dom/Builder/Class.hs @@ -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) diff --git a/src/Reflex/Dom/Builder/Class/Events.hs b/src/Reflex/Dom/Builder/Class/Events.hs --- a/src/Reflex/Dom/Builder/Class/Events.hs +++ b/src/Reflex/Dom/Builder/Class/Events.hs @@ -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 diff --git a/src/Reflex/Dom/Builder/Hydratable.hs b/src/Reflex/Dom/Builder/Hydratable.hs --- a/src/Reflex/Dom/Builder/Hydratable.hs +++ b/src/Reflex/Dom/Builder/Hydratable.hs @@ -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 diff --git a/src/Reflex/Dom/Builder/Immediate.hs b/src/Reflex/Dom/Builder/Immediate.hs --- a/src/Reflex/Dom/Builder/Immediate.hs +++ b/src/Reflex/Dom/Builder/Immediate.hs @@ -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 diff --git a/src/Reflex/Dom/Builder/Static.hs b/src/Reflex/Dom/Builder/Static.hs --- a/src/Reflex/Dom/Builder/Static.hs +++ b/src/Reflex/Dom/Builder/Static.hs @@ -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 () diff --git a/src/Reflex/Dom/Class.hs b/src/Reflex/Dom/Class.hs --- a/src/Reflex/Dom/Class.hs +++ b/src/Reflex/Dom/Class.hs @@ -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`" #-} diff --git a/src/Reflex/Dom/Widget/Basic.hs b/src/Reflex/Dom/Widget/Basic.hs --- a/src/Reflex/Dom/Widget/Basic.hs +++ b/src/Reflex/Dom/Widget/Basic.hs @@ -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 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