reflex-dom-core 0.5 → 0.5.2.0
raw patch · 20 files changed
+420/−146 lines, 20 filesdep +hspec-coredep +semialigndep +whichdep ~aesondep ~basedep ~constraints
Dependencies added: hspec-core, semialign, which
Dependency ranges changed: aeson, base, constraints, containers, contravariant, dependent-map, dependent-sum, dependent-sum-template, reflex, stm, these
Files
- ChangeLog.md +18/−0
- reflex-dom-core.cabal +30/−15
- src/Foreign/JavaScript/Orphans.hs +2/−0
- src/Foreign/JavaScript/TH.hs +2/−4
- src/Reflex/Dom/Builder/Class.hs +1/−2
- src/Reflex/Dom/Builder/Class/Events.hs +0/−1
- src/Reflex/Dom/Builder/Hydratable.hs +116/−0
- src/Reflex/Dom/Builder/Immediate.hs +27/−20
- src/Reflex/Dom/Builder/InputDisabled.hs +6/−0
- src/Reflex/Dom/Builder/Static.hs +1/−1
- src/Reflex/Dom/Core.hs +1/−0
- src/Reflex/Dom/Main.hs +46/−27
- src/Reflex/Dom/Old.hs +0/−1
- src/Reflex/Dom/Prerender.hs +117/−16
- src/Reflex/Dom/Widget/Basic.hs +5/−4
- src/Reflex/Dom/Widget/Lazy.hs +1/−1
- src/Reflex/Dom/Widget/Resize.hs +4/−0
- src/Reflex/Dom/Xhr/Foreign.hs +0/−1
- test/hlint.hs +2/−0
- test/hydration.hs +41/−53
ChangeLog.md view
@@ -1,5 +1,23 @@ # Revision history for reflex-dom-core +## Unreleased++## 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.
reflex-dom-core.cabal view
@@ -1,5 +1,5 @@ Name: reflex-dom-core-Version: 0.5+Version: 0.5.2.0 Synopsis: Functional Reactive Web Apps with Reflex Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine License: BSD3@@ -39,22 +39,27 @@ default: False manual: True +flag split-these+ description: Use split these/semialign packages+ manual: False+ default: True+ library hs-source-dirs: src build-depends:- aeson >= 0.8 && < 1.4,- base >= 4.7 && < 4.12,+ aeson >= 0.8 && < 1.5,+ base >= 4.7 && < 4.13, bifunctors >= 4.2 && < 6, bimap >= 0.3 && < 0.4, blaze-builder, bytestring == 0.10.*,- containers == 0.5.*,- constraints >= 0.9 && < 0.11,- contravariant >= 1.4 && < 1.5,+ containers >= 0.6 && < 0.7,+ constraints >= 0.9 && < 0.12,+ contravariant >= 1.4 && < 1.6, data-default >= 0.5 && < 0.8,- dependent-map == 0.2.*,- dependent-sum >= 0.3 && < 0.5,- dependent-sum-template >= 0.0.0.4 && < 0.1,+ dependent-map >= 0.3 && < 0.4,+ dependent-sum >= 0.6 && < 0.7,+ dependent-sum-template >= 0.1 && < 0.2, directory >= 1.2 && < 1.4, exception-transformers == 0.4.*, ghcjs-dom >= 0.9.1.0 && < 0.10,@@ -67,11 +72,10 @@ primitive >= 0.5 && < 0.7, random, ref-tf == 0.4.*,- reflex == 0.6.*,+ reflex >= 0.6.2, semigroups >= 0.16 && < 0.19,- stm == 2.4.*,+ stm >= 2.4 && < 2.6, text == 1.2.*,- these >= 0.4 && < 0.8, transformers >= 0.3 && < 0.6, network-uri >= 2.6.1 && < 2.7, zenc == 0.1.*@@ -86,6 +90,14 @@ if !os(windows) build-depends: unix == 2.7.* + if flag(split-these)+ build-depends:+ semialign >= 1 && < 1.1,+ these >= 1 && < 1.1+ else+ build-depends:+ these >= 0.4 && < 0.9+ exposed-modules: Foreign.JavaScript.TH Foreign.JavaScript.Orphans@@ -94,6 +106,7 @@ Reflex.Dom.Builder.Class.Events Reflex.Dom.Builder.Immediate Reflex.Dom.Builder.InputDisabled+ Reflex.Dom.Builder.Hydratable Reflex.Dom.Builder.Static Reflex.Dom.Class Reflex.Dom.Core@@ -133,8 +146,8 @@ if flag(use-template-haskell) build-depends:- dependent-sum >= 0.3 && < 0.5,- dependent-sum-template >= 0.0.0.5 && < 0.1,+ dependent-sum >= 0.6,+ dependent-sum-template >= 0.1 && < 0.2, template-haskell other-extensions: TemplateHaskell cpp-options: -DUSE_TEMPLATE_HASKELL@@ -142,7 +155,7 @@ Reflex.Dom.Builder.Class.TH else build-depends:- dependent-sum == 0.4.*+ dependent-sum == 0.6.* test-suite hlint build-depends: base, hlint@@ -166,6 +179,7 @@ , filepath , ghcjs-dom , hspec+ , hspec-core , hspec-webdriver , http-types , HUnit@@ -187,6 +201,7 @@ , warp , webdriver , websockets+ , which hs-source-dirs: test ghc-options: -rtsopts -with-rtsopts=-T -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans ghc-prof-options: -fprof-auto -optP-DPROFILING
src/Foreign/JavaScript/Orphans.hs view
@@ -1,6 +1,8 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-} module Foreign.JavaScript.Orphans where
src/Foreign/JavaScript/TH.hs view
@@ -6,11 +6,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-}@@ -294,7 +292,7 @@ #ifdef ghcjs_HOST_OS data JSCtx_IO-type HasJS' = HasJS JSCtx_IO+type JS' = JSCtx_IO instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where type JSX (WithJSContextSingleton x m) = IO@@ -345,7 +343,7 @@ #else data JSCtx_JavaScriptCore x-type HasJS' = HasJS (JSCtx_JavaScriptCore ())+type JS' = JSCtx_JavaScriptCore () instance IsJSContext (JSCtx_JavaScriptCore x) where newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }
src/Reflex/Dom/Builder/Class.hs view
@@ -11,10 +11,9 @@ {-# LANGUAGE ImpredicativeTypes #-} #endif {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}
src/Reflex/Dom/Builder/Class/Events.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} #ifdef USE_TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-}
+ src/Reflex/Dom/Builder/Hydratable.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Reflex.Dom.Builder.Hydratable where++import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.Ref+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Coerce+import qualified Data.Map as Map+import Foreign.JavaScript.TH+#ifndef ghcjs_HOST_OS+import GHCJS.DOM.Types (MonadJSM (..))+#endif+import Reflex+import Reflex.Dom.Builder.Class+import Reflex.Dom.Builder.Immediate (HasDocument (..))+import Reflex.Host.Class++-- | A DomBuilder transformer that adds "data-ssr" 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)++#ifndef ghcjs_HOST_OS+instance MonadJSM m => MonadJSM (HydratableT m) where+ liftJSM' = HydratableT . liftJSM'+#endif++deriving instance MonadSample t m => MonadSample t (HydratableT m)+deriving instance MonadHold t m => MonadHold t (HydratableT m)++instance MonadTrans HydratableT where+ lift = HydratableT++instance MonadTransControl HydratableT where+ type StT HydratableT a = a+ liftWith f = HydratableT $ f runHydratableT+ restoreT = HydratableT++instance MonadRef m => MonadRef (HydratableT m) where+ type Ref (HydratableT m) = Ref m+ newRef = lift . newRef+ readRef = lift . readRef+ writeRef ref = lift . writeRef ref++instance PerformEvent t m => PerformEvent t (HydratableT m) where+ type Performable (HydratableT m) = Performable m+ performEvent_ = lift . performEvent_+ performEvent = lift . performEvent++instance PrimMonad m => PrimMonad (HydratableT m) where+ type PrimState (HydratableT m) = PrimState m+ primitive = lift . primitive++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+ }++instance PostBuild t m => PostBuild t (HydratableT m) where+ getPostBuild = lift getPostBuild++deriving instance TriggerEvent t m => TriggerEvent t (HydratableT m)++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydratableT m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance Adjustable t m => Adjustable t (HydratableT m) where+ runWithReplace a0 a' = HydratableT $ runWithReplace (coerce a0) (coerceEvent a')+ traverseDMapWithKeyWithAdjust f dm0 dm' = HydratableT $ traverseDMapWithKeyWithAdjust (\k v -> runHydratableT $ f k v) (coerce dm0) (coerceEvent dm')+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = HydratableT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runHydratableT $ f k v) (coerce dm0) (coerceEvent dm')+ traverseIntMapWithKeyWithAdjust f m0 m' = HydratableT $ traverseIntMapWithKeyWithAdjust (\k v -> runHydratableT $ f k v) (coerce m0) (coerceEvent m')++instance NotReady t m => NotReady t (HydratableT m) where+ notReadyUntil = lift . notReadyUntil+ notReady = lift notReady++instance DomBuilder t m => DomBuilder t (HydratableT m) where+ type DomBuilderSpace (HydratableT m) = DomBuilderSpace m+ element t cfg = lift . element t (makeHydratable cfg) . runHydratableT+ inputElement cfg = lift $ inputElement $ cfg+ { _inputElementConfig_elementConfig = makeHydratable $ _inputElementConfig_elementConfig cfg+ }+ textAreaElement cfg = lift $ textAreaElement $ cfg+ { _textAreaElementConfig_elementConfig = makeHydratable $ _textAreaElementConfig_elementConfig cfg+ }+ selectElement cfg child = do+ let cfg' = cfg+ { _selectElementConfig_elementConfig = makeHydratable $ _selectElementConfig_elementConfig cfg+ }+ lift $ selectElement cfg' $ runHydratableT child++instance HasDocument m => HasDocument (HydratableT m)++instance HasJSContext m => HasJSContext (HydratableT m) where+ type JSContextPhantom (HydratableT m) = JSContextPhantom m+ askJSContext = lift askJSContext++instance HasJS js m => HasJS js (HydratableT m) where+ type JSX (HydratableT m) = JSX m+ liftJS = lift . liftJS++instance DomRenderHook t m => DomRenderHook t (HydratableT m) where+ withRenderHook f = HydratableT . withRenderHook f . runHydratableT+ requestDomAction = HydratableT . requestDomAction+ requestDomAction_ = HydratableT . requestDomAction_
src/Reflex/Dom/Builder/Immediate.hs view
@@ -347,7 +347,7 @@ flip runTriggerEventT events $ do rec (result, req) <- runRequesterT a rsp rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $- traverseRequesterData (\r -> Identity <$> r) rm+ traverseRequesterData (fmap Identity) rm return result where runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do@@ -362,7 +362,7 @@ withRenderHook hook (DomRenderHookT a) = do DomRenderHookT $ withRequesting $ \rsp -> do (x, req) <- lift $ runRequesterT a $ runIdentity <$> rsp- return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)+ return (ffor req $ \rm -> hook $ traverseRequesterData (fmap Identity) rm, x) requestDomAction = DomRenderHookT . requestingIdentity requestDomAction_ = DomRenderHookT . requesting_ @@ -764,11 +764,18 @@ } result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env' wrapResult <- liftIO newEmptyMVar- let ssrAttr = "data-ssr" :: DOM.JSString- hasSSRAttribute :: DOM.Element -> HydrationRunnerT t m Bool- hasSSRAttribute e = case cfg ^. namespace of- Nothing -> hasAttribute e ssrAttr <* removeAttribute e ssrAttr- Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr+ let skipAttr = "data-hydration-skip" :: DOM.JSString+ ssrAttr = "data-ssr" :: DOM.JSString+ 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 childDom <- liftIO $ readIORef childDelayedRef let rawCfg = extractRawElementConfig cfg doc <- askDocument@@ -783,9 +790,9 @@ pure e Just node -> DOM.castTo DOM.Element node >>= \case Nothing -> go (Just node) -- this node is not an element, skip- Just e -> hasSSRAttribute e >>= \case- False -> go (Just node) -- this element was not added by the static renderer, skip- True -> do+ Just e -> shouldSkip e >>= \case+ True -> go (Just node) -- this element is explicitly marked for being skipped by hydration+ False -> do t <- Element.getTagName e -- TODO: check attributes? if T.toCaseFold elementTag == T.toCaseFold t@@ -1555,13 +1562,13 @@ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete ChildReadyState_Unready _ -> do- writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate) PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a) deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do- writeIORef sRef $ ChildReadyState_Unready $ This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases+ writeIORef sRef $ ChildReadyState_Unready $ Some <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases return $ Constant () p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old@@ -1571,8 +1578,8 @@ phsBefore <- liftIO $ readIORef placeholders let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a) collectIfMoved k e = do- let mThisPlaceholder = Map.lookup (This k) phsBefore -- Will be Nothing if this element wasn't present before- nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsBefore+ let mThisPlaceholder = Map.lookup (Some k) phsBefore -- Will be Nothing if this element wasn't present before+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsBefore case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of False -> do mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder@@ -1591,7 +1598,7 @@ PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a) placeFragment k e = do- let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsAfter+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsAfter case PatchDMapWithMove._nodeInfo_from e of PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of Left _ -> pure ()@@ -1622,7 +1629,7 @@ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready ChildReadyState_Unready _ -> do- writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate) delete _ (Constant sRef) = do writeIORef sRef $ ChildReadyState_Unready Nothing@@ -1633,9 +1640,9 @@ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do phs <- liftIO $ readIORef placeholders forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do- let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phs+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phs -- Delete old node- forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do+ forM_ (Map.lookup (Some k) phs) $ \thisPlaceholder -> do thisPlaceholder `deleteUpTo` nextPlaceholder -- Insert new node forM_ mv $ \(Compose (TraverseChild e _)) -> case e of@@ -1785,7 +1792,7 @@ liftIO $ writeIORef childReadyState ChildReadyState_Ready case countedAt of Nothing -> return ()- Just (This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set+ Just (Some k) -> do -- This child has been counted as unready, so we need to remove it from the unready set (oldUnready, p) <- liftIO $ readIORef pendingChange when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null let newUnready = DMap.delete k oldUnready@@ -1800,7 +1807,7 @@ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case ChildReadyState_Ready -> return Nothing ChildReadyState_Unready _ -> do- writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate) initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0 liftIO $ if DMap.null initialUnready
src/Reflex/Dom/Builder/InputDisabled.hs view
@@ -80,6 +80,7 @@ runWithReplace a0 a' = InputDisabledT $ runWithReplace (coerce a0) (coerceEvent a') traverseDMapWithKeyWithAdjust f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm') traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')+ traverseIntMapWithKeyWithAdjust f m0 m' = InputDisabledT $ traverseIntMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce m0) (coerceEvent m') instance NotReady t m => NotReady t (InputDisabledT m) where notReadyUntil = lift . notReadyUntil@@ -108,3 +109,8 @@ instance HasJS js m => HasJS js (InputDisabledT m) where type JSX (InputDisabledT m) = JSX m liftJS = lift . liftJS++instance DomRenderHook t m => DomRenderHook t (InputDisabledT m) where+ withRenderHook f = InputDisabledT . withRenderHook f . runInputDisabledT+ requestDomAction = InputDisabledT . requestDomAction+ requestDomAction_ = InputDisabledT . requestDomAction_
src/Reflex/Dom/Builder/Static.hs view
@@ -288,7 +288,7 @@ StaticDomBuilderT $ do let shouldEscape = elementTag `Set.notMember` noEscapeElements (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing- attrs0 <- foldDyn applyMap (Map.insert "data-ssr" "" $ cfg ^. initialAttributes) (cfg ^. modifyAttributes)+ attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes) selectValue <- asks _staticDomBuilderEnv_selectValue let addSelectedAttr attrs sel = case Map.lookup "value" attrs of Just v | v == sel -> attrs <> Map.singleton "selected" ""
src/Reflex/Dom/Core.hs view
@@ -6,6 +6,7 @@ import Reflex as X hiding (askEvents) import Reflex.Dom.Builder.Class as X+import Reflex.Dom.Builder.Hydratable as X import Reflex.Dom.Builder.Immediate as X import Reflex.Dom.Builder.InputDisabled as X import Reflex.Dom.Builder.Static as X
src/Reflex/Dom/Main.hs view
@@ -121,8 +121,8 @@ {-# INLINABLE runHydrationWidgetWithHeadAndBody #-} runHydrationWidgetWithHeadAndBody :: JSM ()- -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"- -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body"+ -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head" --TODO: test invoking this more than once+ -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body" --TODO: test invoking this more than once -> FloatingWidget () () ) -> JSM ()@@ -212,39 +212,48 @@ attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w --- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.-mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> JSM ()-mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do- doc <- currentDocumentUnchecked- headElement <- getHeadUnchecked doc- headFragment <- createDocumentFragment doc- bodyElement <- getBodyUnchecked doc- bodyFragment <- createDocumentFragment doc- hydrationMode <- liftIO $ newIORef HydrationMode_Immediate- (events, fc) <- liftIO . attachWidget'' $ \events -> do- let (headWidget, bodyWidget) = widgets+{-# INLINABLE runImmediateWidgetWithHeadAndBody #-}+runImmediateWidgetWithHeadAndBody+ :: ( (forall c. Widget () c -> FloatingWidget () c) -- "Append to head"+ -> (forall c. Widget () c -> FloatingWidget () c) -- "Append to body"+ -> FloatingWidget () ()+ )+ -> JSM ()+runImmediateWidgetWithHeadAndBody app = withJSContextSingletonMono $ \jsSing -> do+ globalDoc <- currentDocumentUnchecked+ headElement <- getHeadUnchecked globalDoc+ bodyElement <- getBodyUnchecked globalDoc+ headFragment <- createDocumentFragment globalDoc+ bodyFragment <- createDocumentFragment globalDoc+ (events, fc) <- liftIO . attachImmediateWidget $ \hydrationMode events -> do (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef- let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c- go w df = do+ let go :: forall c. DOM.DocumentFragment -> Widget () c -> FloatingWidget () c+ go df w = do unreadyChildren <- liftIO $ newIORef 0 delayed <- liftIO $ newIORef $ pure () let builderEnv = HydrationDomBuilderEnv- { _hydrationDomBuilderEnv_document = toDocument doc+ { _hydrationDomBuilderEnv_document = globalDoc , _hydrationDomBuilderEnv_parent = Left $ toNode df , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren- , _hydrationDomBuilderEnv_commitAction = return () --TODO+ , _hydrationDomBuilderEnv_commitAction = pure () --TODO: possibly `replaceElementContents n f`+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode , _hydrationDomBuilderEnv_switchover = never , _hydrationDomBuilderEnv_delayed = delayed- , _hydrationDomBuilderEnv_hydrationMode = hydrationMode }- runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing- rec b <- go (headWidget a) headFragment- a <- go (bodyWidget b) bodyFragment+ lift $ runHydrationDomBuilderT w builderEnv events+ runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (go headFragment) (go bodyFragment)) events) postBuild) jsSing return (events, postBuildTriggerRef) replaceElementContents headElement headFragment replaceElementContents bodyElement bodyFragment liftIO $ processAsyncEvents events fc +-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.+mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> JSM ()+mainWidgetWithHead' (h, b) = runImmediateWidgetWithHeadAndBody $ \appendHead appendBody -> do+ rec hOut <- appendHead $ h bOut+ bOut <- appendBody $ b hOut+ pure ()+ replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> JSM () replaceElementContents e df = do setInnerHTML e ("" :: String)@@ -256,8 +265,7 @@ attachWidget' rootElement jsSing w = do doc <- getOwnerDocumentUnchecked rootElement df <- createDocumentFragment doc- hydrationMode <- liftIO $ newIORef HydrationMode_Immediate- ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do+ ((a, events), fc) <- liftIO . attachImmediateWidget $ \hydrationMode events -> do (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef unreadyChildren <- liftIO $ newIORef 0 delayed <- liftIO $ newIORef $ pure ()@@ -278,12 +286,18 @@ type EventChannel = Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation] -{-# INLINABLE attachWidget'' #-}-attachWidget'' :: (EventChannel -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))) -> IO (a, FireCommand DomTimeline DomHost)-attachWidget'' w = do+{-# INLINABLE attachImmediateWidget #-}+attachImmediateWidget+ :: ( IORef HydrationMode+ -> EventChannel+ -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))+ )+ -> IO (a, FireCommand DomTimeline DomHost)+attachImmediateWidget w = do+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate events <- newChan runDomHost $ do- ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events+ ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w hydrationMode events mPostBuildTrigger <- readRef postBuildTriggerRef forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return () return (result, fc)@@ -325,3 +339,8 @@ { _appInput_window = w } return ()++{-# DEPRECATED attachWidget'' "Use 'attachImmediateWidget . const' instead" #-}+{-# INLINABLE attachWidget'' #-}+attachWidget'' :: (EventChannel -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))) -> IO (a, FireCommand DomTimeline DomHost)+attachWidget'' = attachImmediateWidget . const
src/Reflex/Dom/Old.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}
src/Reflex/Dom/Prerender.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- | Render the first widget on the server, and the second on the client. module Reflex.Dom.Prerender@@ -21,21 +22,22 @@ , PrerenderBaseConstraints ) where -import Control.Monad.Primitive (PrimMonad)+import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader import Control.Monad.Ref (MonadRef(..)) import Data.IORef (IORef, newIORef) import Data.Semigroup (Semigroup) import Data.Text (Text)+import Data.Void import Foreign.JavaScript.TH import GHCJS.DOM.Types (MonadJSM) import Reflex hiding (askEvents) import Reflex.Dom.Builder.Class+import Reflex.Dom.Builder.Hydratable import Reflex.Dom.Builder.Immediate import Reflex.Dom.Builder.InputDisabled import Reflex.Dom.Builder.Static import Reflex.Host.Class-import Reflex.Requester.Base import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap @@ -49,7 +51,6 @@ , DomRenderHook t m , HasDocument m , TriggerEvent t m- , Prerender js t m , PrerenderBaseConstraints js t m ) @@ -77,16 +78,16 @@ -- hydration builder will run *both* widgets. prerender_ :: (Functor m, Reflex t, Prerender js t m)- => m () -> ((PrerenderClientConstraint js t (Client m)) => Client m ()) -> m ()+ => m () -> Client m () -> m () prerender_ server client = void $ prerender server client -class Prerender js t m | m -> t js where+class (PrerenderClientConstraint js t (Client m), Client (Client m) ~ Client m, Prerender js t (Client m)) => Prerender js t m | m -> t js where -- | Monad in which the client widget is built type Client m :: * -> * -- | Render the first widget on the server, and the second on the client. The -- hydration builder will run *both* widgets, updating the result dynamic at -- switchover time.- prerender :: m a -> ((PrerenderClientConstraint js t (Client m)) => Client m a) -> m (Dynamic t a)+ prerender :: m a -> Client m a -> m (Dynamic t a) instance (ReflexHost t, Adjustable t m, PrerenderBaseConstraints js t m) => Prerender js t (HydrationDomBuilderT GhcjsDomSpace t m) where type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m@@ -131,10 +132,106 @@ insertBefore df =<< deleteToPrerenderEnd doc holdDyn a0 a' -data NoJavaScript -- This type should never have a HasJS instance+newtype UnrunnableT js t m a = UnrunnableT (ReaderT Void m a)+ deriving (Functor, Applicative, Monad, MonadTrans) -instance (js ~ NoJavaScript, SupportsStaticDomBuilder t m) => Prerender js t (StaticDomBuilderT t m) where- type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m+unrunnable :: UnrunnableT js t m a+unrunnable = UnrunnableT $ ReaderT $ \case {}++instance (Reflex t, Monad m) => DomBuilder t (UnrunnableT js t m) where+ type DomBuilderSpace (UnrunnableT js t m) = GhcjsDomSpace+ textNode _ = unrunnable+ commentNode _ = unrunnable+ element _ _ _ = unrunnable+ inputElement _ = unrunnable+ textAreaElement _ = unrunnable+ selectElement _ _ = unrunnable+ placeRawElement _ = unrunnable+ wrapRawElement _ _ = unrunnable+instance (Reflex t, Monad m) => NotReady t (UnrunnableT js t m) where+ notReadyUntil _ = unrunnable+ notReady = unrunnable+instance (Reflex t, Monad m) => Adjustable t (UnrunnableT js t m) where+ runWithReplace _ _ = unrunnable+ traverseIntMapWithKeyWithAdjust _ _ _ = unrunnable+ traverseDMapWithKeyWithAdjust _ _ _ = unrunnable+ traverseDMapWithKeyWithAdjustWithMove _ _ _ = unrunnable+instance (Reflex t, Monad m) => PerformEvent t (UnrunnableT js t m) where+ type Performable (UnrunnableT js t m) = UnrunnableT js t m+ performEvent _ = unrunnable+ performEvent_ _ = unrunnable+instance Monad m => MonadRef (UnrunnableT js t m) where+ type Ref (UnrunnableT js t m) = Ref IO+ newRef _ = unrunnable+ readRef _ = unrunnable+ writeRef _ _ = unrunnable+instance Monad m => HasDocument (UnrunnableT js t m) where+ askDocument = unrunnable+instance Monad m => HasJSContext (UnrunnableT js t m) where+ type JSContextPhantom (UnrunnableT js t m) = ()+ askJSContext = unrunnable+instance Monad m => HasJS JS' (UnrunnableT js t m) where+ type JSX (UnrunnableT js t m) = UnrunnableT js t m+ liftJS _ = unrunnable+instance Monad m => MonadJS JS' (UnrunnableT js t m) where+ runJS _ _ = unrunnable+ forkJS _ = unrunnable+ mkJSUndefined = unrunnable+ isJSNull _ = unrunnable+ isJSUndefined _ = unrunnable+ fromJSBool _ = unrunnable+ fromJSString _ = unrunnable+ fromJSArray _ = unrunnable+ fromJSUint8Array _ = unrunnable+ fromJSNumber _ = unrunnable+ withJSBool _ _ = unrunnable+ withJSString _ _ = unrunnable+ withJSNumber _ _ = unrunnable+ withJSArray _ _ = unrunnable+ withJSUint8Array _ _ = unrunnable+ mkJSFun _ = unrunnable+ freeJSFun _ = unrunnable+ setJSProp _ _ _ = unrunnable+ getJSProp _ _ = unrunnable+ withJSNode _ _ = unrunnable+instance Monad m => TriggerEvent t (UnrunnableT js t m) where+ newTriggerEvent = unrunnable+ newTriggerEventWithOnComplete = unrunnable+ newEventWithLazyTriggerWithOnComplete _ = unrunnable+instance Monad m => MonadReflexCreateTrigger t (UnrunnableT js t m) where+ newEventWithTrigger _ = unrunnable+ newFanEventWithTrigger _ = unrunnable+instance Monad m => MonadFix (UnrunnableT js t m) where+ mfix _ = unrunnable+instance Monad m => MonadHold t (UnrunnableT js t m) where+ hold _ _ = unrunnable+ holdDyn _ _ = unrunnable+ holdIncremental _ _ = unrunnable+ buildDynamic _ _ = unrunnable+ headE _ = unrunnable+instance Monad m => MonadSample t (UnrunnableT js t m) where+ sample _ = unrunnable+instance Monad m => MonadIO (UnrunnableT js t m) where+ liftIO _ = unrunnable+#ifndef ghcjs_HOST_OS+instance Monad m => MonadJSM (UnrunnableT js t m) where+ liftJSM' _ = unrunnable+#endif+instance (Reflex t, Monad m) => PostBuild t (UnrunnableT js t m) where+ getPostBuild = unrunnable+instance Monad m => PrimMonad (UnrunnableT js t m) where+ type PrimState (UnrunnableT js t m) = PrimState IO+ primitive _ = unrunnable+instance (Reflex t, Monad m) => DomRenderHook t (UnrunnableT js t m) where+ withRenderHook _ _ = unrunnable+ requestDomAction _ = unrunnable+ requestDomAction_ _ = unrunnable+instance (Reflex t, Monad m) => Prerender JS' t (UnrunnableT js t m) where+ type Client (UnrunnableT js t m) = UnrunnableT js t m+ prerender _ _ = unrunnable++instance (SupportsStaticDomBuilder t m) => Prerender JS' t (StaticDomBuilderT t m) where+ type Client (StaticDomBuilderT t m) = UnrunnableT JS' t m prerender server _ = do _ <- commentNode $ CommentNodeConfig startMarker Nothing a <- server@@ -174,8 +271,8 @@ (x, e) <- runRequesterT w (selectInt fannedResponses selector) pure (x, fmapCheap (IntMap.singleton selector) e) (result, requestsDyn) <- fmap splitDynPure $ lift $ prerender (withFannedResponses server 0) (withFannedResponses client 1)- responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switch $ current requestsDyn- pure result+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requestsDyn+ return result instance (Prerender js t m, Monad m, Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q) => Prerender js t (QueryT t q m) where type Client (QueryT t q m) = QueryT t q (Client m)@@ -187,8 +284,12 @@ pure a instance (Prerender js t m, Monad m) => Prerender js t (InputDisabledT m) where- type Client (InputDisabledT m) = Client m- prerender (InputDisabledT server) client = InputDisabledT $ prerender server client+ type Client (InputDisabledT m) = InputDisabledT (Client m)+ prerender (InputDisabledT server) (InputDisabledT client) = InputDisabledT $ prerender server client++instance (Prerender js t m, Monad m) => Prerender js t (HydratableT m) where+ type Client (HydratableT m) = HydratableT (Client m)+ prerender (HydratableT server) (HydratableT client) = HydratableT $ prerender server client instance (Prerender js t m, Monad m, ReflexHost t) => Prerender js t (PostBuildT t m) where type Client (PostBuildT t m) = PostBuildT t (Client m)
src/Reflex/Dom/Widget/Basic.hs view
@@ -60,6 +60,7 @@ , partitionMapBySetLT ) where +import Reflex.Adjustable.Class import Reflex.Class import Reflex.Collection import Reflex.Dom.Builder.Class@@ -146,21 +147,21 @@ -- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates. -- The returned Event of widget results occurs when the Dynamic does. -- Note: Often, the type @a@ is an 'Event', in which case the return value is an Event-of-Events that would typically be flattened (via 'switchHold').-dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)+dyn :: (Adjustable t m, NotReady t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a) dyn = networkView -- | Like 'dyn' but discards result.-dyn_ :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m ()+dyn_ :: (Adjustable t m, NotReady t m, PostBuild t m) => Dynamic t (m a) -> m () dyn_ = void . dyn -- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires. -- The returned Dynamic of widget results occurs when the Event does. -- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened (via 'switchDyn').-widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)+widgetHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a) widgetHold = networkHold -- | Like 'widgetHold' but discards result.-widgetHold_ :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m ()+widgetHold_ :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m () widgetHold_ z = void . widgetHold z -- | Create a DOM element
src/Reflex/Dom/Widget/Lazy.hs view
@@ -108,7 +108,7 @@ uniqWindow <- holdUniqDyn window return (uniqWindow, result) where- toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m+ toStyleAttr m = "style" =: Map.foldrWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <> "left" =: "0" <> "right" =: "0" <> "height" =: (T.pack (show h) <> "px") mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (T.pack (show h) <> "px")
src/Reflex/Dom/Widget/Resize.hs view
@@ -33,6 +33,10 @@ -- | A widget that wraps the given widget in a div and fires an event when resized. -- Adapted from @github.com\/marcj\/css-element-queries@+--+-- 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 = resizeDetectorWithStyle ""
src/Reflex/Dom/Xhr/Foreign.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-} module Reflex.Dom.Xhr.Foreign ( XMLHttpRequest
test/hlint.hs view
@@ -16,9 +16,11 @@ , "--ignore=Use unless" , "--ignore=Use if" , "--ignore=Use fewer imports"+ , "--ignore=Use list comprehension" , "--ignore=Unnecessary hiding" -- Interferes with cross-version compatibility , "--ignore=Use <$>" , "--ignore=Reduce duplication" --TODO: Re-enable this test+ , "--ignore=Use list comprehension" , "--cpp-define=USE_TEMPLATE_HASKELL" ] if null ideas then exitSuccess else exitFailure
test/hydration.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -19,9 +20,11 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +import Prelude hiding (fail) import Control.Concurrent-import Control.Monad+import Control.Monad hiding (fail) import Control.Monad.Catch+import Control.Monad.Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Ref@@ -35,7 +38,6 @@ import Data.GADT.Show.TH import Data.IORef (IORef) import Data.Maybe-import Data.Monoid import Data.Proxy import Data.Text (Text) import Language.Javascript.JSaddle (syncPoint, liftJSM)@@ -52,12 +54,15 @@ import System.IO.Silently import System.IO.Temp import System.Process+import System.Which (staticWhich) import qualified Test.HUnit as HUnit (assertEqual, assertFailure) 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@@ -73,6 +78,9 @@ import Test.Util.ChromeFlags import Test.Util.UnshareNetwork +chromium :: FilePath+chromium = $(staticWhich "chromium")+ seleniumPort, jsaddlePort :: PortNumber seleniumPort = 8000 jsaddlePort = 8001@@ -116,16 +124,7 @@ deriveGCompare ''DKey deriveGShow ''DKey -instance ShowTag DKey Identity where- showTaggedPrec = \case- Key_Int -> showsPrec- Key_Char -> showsPrec- Key_Bool -> showsPrec--instance EqTag DKey Identity where- eqTagged Key_Int Key_Int = (==)- eqTagged Key_Char Key_Char = (==)- eqTagged Key_Bool Key_Bool = (==)+deriving instance MonadFail WD main :: IO () main = do@@ -133,9 +132,9 @@ isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS" withSandboxedChromeFlags isHeadless $ \chromeFlags -> do withSeleniumServer $ \selenium -> do- browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""+ let browserPath = T.strip $ T.pack chromium when (T.null browserPath) $ fail "No browser found"- withDebugging <- isJust <$> lookupEnv "DEBUG"+ withDebugging <- isNothing <$> lookupEnv "NO_DEBUG" let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium } chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium@@ -280,13 +279,6 @@ (e, ()) <- element "div" conf $ text "hello world" let click = domEvent Click e return ()- -- TODO check this is the correct solution- it "has ssr attribute, removes ssr attribute" $ runWD $ do- let checkSSRAttr = do- e <- findElemWithRetry $ WD.ByTag "div"- assertAttr e "data-ssr" (Just "")- pure e- testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world" describe "inputElement" $ do describe "hydration" $ session' $ do@@ -754,9 +746,9 @@ pb <- getPostBuild performEvent_ $ liftIO (putMVar lock ()) <$ pb it "result Dynamic is updated *after* switchover" $ runWD $ do- let static = checkBodyText "PostBuild"+ let preSwitchover = checkBodyText "PostBuild" check = checkBodyText "Client"- testWidget static check $ void $ do+ testWidget preSwitchover check $ void $ do d <- prerender (pure "Initial") (pure "Client") pb <- getPostBuild initial <- sample $ current d@@ -764,16 +756,16 @@ -- This essentially checks that the client IO runs *after* switchover/postBuild, -- thus can't create conflicting DOM it "can't exploit IO to break hydration" $ runWD $ do- let static = checkBodyText "Initial"- testWidgetStatic static $ void $ do+ let preSwitchover = checkBodyText "Initial"+ testWidgetStatic preSwitchover $ void $ do ref <- liftIO $ newRef "Initial" prerender_ (pure ()) (liftIO $ writeRef ref "Client") text <=< liftIO $ readRef ref -- As above, so below it "can't exploit triggerEvent to break hydration" $ runWD $ do- let static = checkBodyText "Initial"+ let preSwitchover = checkBodyText "Initial" check = checkBodyText "Client"- testWidget static check $ void $ do+ testWidget preSwitchover check $ void $ do (e, trigger) <- newTriggerEvent prerender_ (pure ()) (liftIO $ trigger "Client") textNode $ TextNodeConfig "Initial" $ Just e@@ -812,7 +804,7 @@ , el "span" . text <$> replace ] it "can be nested in postBuild widget" $ runWD $ do- replaceChan <- liftIO newChan+ replaceChan :: Chan Text <- liftIO newChan let setup = findElemWithRetry $ WD.ByTag "div" check ssr = do -- Check that the original element still exists and has the correct text@@ -962,26 +954,26 @@ postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)] it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do chan <- liftIO newChan- let static :: WD [WD.Element]- static = getAndCheckInitialItems keyMap+ let preSwitchover :: WD [WD.Element]+ preSwitchover = getAndCheckInitialItems keyMap check :: [WD.Element] -> WD () check xs = do checkInitialItems keyMap xs checkRemoval chan Key_Int checkReplace chan Key_Char 'B' checkInsert chan Key_Bool True- testWidget' static check $ do+ testWidget' preSwitchover check $ do (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan liftIO $ dmap `H.shouldBe` keyMap it "handles postBuild correctly" $ runWD $ do chan <- liftIO newChan- let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap+ let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap check xs = do withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs checkRemoval chan Key_Int checkInsert chan Key_Char 'B' checkReplace chan Key_Bool True- testWidget' static check $ void $ do+ testWidget' preSwitchover check $ void $ do pb <- getPostBuild replace <- triggerEventWithChan chan (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]@@ -1071,24 +1063,24 @@ postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")] xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do chan <- liftIO newChan- let static = getAndCheckInitialItems intMap+ let preSwitchover = getAndCheckInitialItems intMap check xs = do checkInitialItems intMap xs checkRemoval chan 1 checkReplace chan 2 "deux" checkInsert chan 4 "four"- testWidget' static check $ void $ do+ testWidget' preSwitchover check $ void $ do (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan liftIO $ im `H.shouldBe` intMap xit "handles postBuild correctly" $ runWD $ do chan <- liftIO newChan- let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap+ let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap check xs = do withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs checkRemoval chan 1 checkInsert chan 2 "deux" checkReplace chan 3 "trois"- testWidget' static check $ void $ do+ testWidget' preSwitchover check $ void $ do pb <- getPostBuild replace <- triggerEventWithChan chan (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]@@ -1153,6 +1145,9 @@ xs <- WD.findElems (WD.ByTag "li") checkInitialItems dm xs pure xs+ moveSpec+ :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())+ -> H.SpecM (WdTestSession ()) () moveSpec testMove = do it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do shouldContainText (T.strip $ T.unlines ["i11","i33"]) body@@ -1180,19 +1175,19 @@ describe "hydration" $ moveSpec $ \initMap test -> do chan <- liftIO newChan- let static = getAndCheckInitialItems initMap+ let preSwitchover = getAndCheckInitialItems initMap check xs = do checkInitialItems initMap xs body <- getBody test body chan- testWidget' static check $ void $ do+ testWidget' preSwitchover check $ void $ do (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan liftIO $ assertEqual "DMap" initMap dmap describe "hydration/immediate" $ moveSpec $ \initMap test -> do chan <- liftIO newChan replace <- liftIO newChan- lock <- liftIO newEmptyMVar+ lock :: MVar () <- liftIO newEmptyMVar let check = do liftIO $ do writeChan replace ()@@ -1211,10 +1206,12 @@ describe "hydrating invalid HTML" $ session' $ do it "can hydrate list in paragraph" $ runWD $ do- let static = do+ let preSwitchover = do checkBodyText "before\ninner\nafter" -- Two <p> tags should be present- [p1, p2] <- WD.findElems (WD.ByTag "p")+ (p1, p2) <- WD.findElems (WD.ByTag "p") >>= \case+ [p1, p2] -> pure (p1, p2)+ _ -> error "Unexpected number of `p` tags (expected 2)" ol <- findElemWithRetry (WD.ByTag "ol") shouldContainText "before" p1 shouldContainText "inner" ol@@ -1225,7 +1222,7 @@ shouldContainText "before\ninner\nafter" p1 elementShouldBeRemoved ol elementShouldBeRemoved p2- testWidget' static check $ do+ testWidget' preSwitchover check $ do -- This is deliberately invalid HTML, the browser will interpret it as -- <p>before</p><ol>inner</ol>after<p></p> el "p" $ do@@ -1359,7 +1356,7 @@ bodyWidget el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False putStrLnDebug "rendering static"- ((), html) <- liftIO $ renderStatic staticApp+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp putStrLnDebug "rendered static" waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover@@ -1417,12 +1414,3 @@ deriveGCompare ''Key2 deriveGShow ''Key2 deriveArgDict ''Key2--instance ShowTag Key2 Identity where- showTaggedPrec = \case- Key2_Int _ -> showsPrec- Key2_Char _ -> showsPrec--instance EqTag Key2 Identity where- eqTagged (Key2_Int _) (Key2_Int _) = (==)- eqTagged (Key2_Char _) (Key2_Char _) = (==)