git.iko.soy/reflex-dom
on develop help sign in
Merge branch 'ts-hydration' into is-dont-hardcode-chromium
d0e45a6Luigy Leon
reflex-dom-core/reflex-dom-core.cabal+6−1
compare with develop
unifiedsplit
@@ -155,10 +155,15 @@ test-suite hydration
155 build-depends: base
155 build-depends: base
156 , aeson
156 , aeson
157 , bytestring
157 , bytestring
158+ , constraints
159+ , constraints-extras
158 , containers
160 , containers
161+ , dependent-map
162+ , dependent-sum
163+ , dependent-sum-template
159 , directory
164 , directory
160− , filepath
161 , exceptions
165 , exceptions
166+ , filepath
162 , ghcjs-dom
167 , ghcjs-dom
163 , hspec
168 , hspec
164 , http-types
169 , http-types
reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+241−145
@@ -59,6 +59,7 @@ import Control.Monad.Primitive
59import Control.Monad.Reader
59import Control.Monad.Reader
60import Control.Monad.Ref
60import Control.Monad.Ref
61import Control.Monad.State.Strict
61import Control.Monad.State.Strict
62+import Data.Default
62import Data.Dependent.Map (DMap)
63import Data.Dependent.Map (DMap)
63import Data.Dependent.Sum
64import Data.Dependent.Sum
64import Data.FastMutableIntMap (PatchIntMap (..))
65import Data.FastMutableIntMap (PatchIntMap (..))
@@ -188,11 +189,11 @@ addHydrationStepWithSetup setup f = getHydrationMode >>= \case
188 HydrationDomBuilderT $ modify' (>> f s)
189 HydrationDomBuilderT $ modify' (>> f s)
189
190
190-- | Add a hydration step
191-- | Add a hydration step
192+addHydrationStep
191−addHydrationStep :: (MonadIO m, Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m)) => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()
193+ :: (MonadIO m, Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
194+ => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()
192addHydrationStep m = getHydrationMode >>= \case
195addHydrationStep m = getHydrationMode >>= \case
193− HydrationMode_Immediate -> do
194− events <- askEvents
195− lift $ runHydrationRunnerT m Nothing undefined events
196+ HydrationMode_Immediate -> lift . runHydrationRunnerT m Nothing undefined =<< askEvents
196 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify' (>> m)
197 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify' (>> m)
197
198
198-- | A monad for DomBuilder which just gets the results of children and pushes
199-- | A monad for DomBuilder which just gets the results of children and pushes
@@ -387,6 +388,35 @@ wrap events e cfg = do
387 return $ en :=> EventFilterTriggerRef triggerRef
388 return $ en :=> EventFilterTriggerRef triggerRef
388 return eventTriggerRefs
389 return eventTriggerRefs
389
390
391+triggerBody
392+ :: forall er t x. DOM.JSContextRef
393+ -> ElementConfig er t GhcjsDomSpace
394+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
395+ -> DMap EventName (EventFilterTriggerRef t er)
396+ -> DOM.Element
397+ -> WrapArg er EventName x
398+ -> EventTrigger t x
399+ -> IO (IO ())
400+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
401+ Just (EventFilterTriggerRef r) -> do
402+ writeIORef r $ Just t
403+ return $ do
404+ writeIORef r Nothing
405+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
406+ evt <- DOM.event
407+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
408+ case mv of
409+ Nothing -> return ()
410+ Just v -> liftIO $ do
411+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
412+ ref <- newIORef $ Just t
413+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
414+ where
415+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
416+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
417+ handler :: GhcjsEventHandler er
418+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg
419+
390{-# INLINABLE makeElement #-}
420{-# INLINABLE makeElement #-}
391makeElement
421makeElement
392 :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m)
422 :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m)
@@ -413,25 +443,6 @@ makeElement elementTag cfg child = do
413 hasSSRAttribute e = case cfg ^. namespace of
443 hasSSRAttribute e = case cfg ^. namespace of
414 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr
444 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr
415 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr
445 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr
416− -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
417− -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
418− handler :: GhcjsEventHandler er
419− !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg
420− triggerBody :: DMap EventName (EventFilterTriggerRef t er) -> DOM.Element -> WrapArg er EventName x -> EventTrigger t x -> IO (IO ())
421− triggerBody eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
422− Just (EventFilterTriggerRef r) -> do
423− writeIORef r $ Just t
424− return $ do
425− writeIORef r Nothing
426− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
427− evt <- DOM.event
428− mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
429− case mv of
430− Nothing -> return ()
431− Just v -> liftIO $ do
432− --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
433− ref <- newIORef $ Just t
434− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
435 getHydrationMode >>= \case
446 getHydrationMode >>= \case
436 HydrationMode_Immediate -> do
447 HydrationMode_Immediate -> do
437 e <- makeNodeInternal buildElement
448 e <- makeNodeInternal buildElement
@@ -439,7 +450,7 @@ makeElement elementTag cfg child = do
439 -- Run the child builder with updated parent and previous sibling references
450 -- Run the child builder with updated parent and previous sibling references
440 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) child
451 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) child
441 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg
452 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg
442− es <- newFanEventWithTrigger $ triggerBody eventTriggerRefs e
453+ es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e
443 e' <- liftIO $ newIORef e
454 e' <- liftIO $ newIORef e
444 return ((Element es e, result), e')
455 return ((Element es e, result), e')
445 HydrationMode_Hydrating -> do
456 HydrationMode_Hydrating -> do
@@ -469,7 +480,7 @@ makeElement elementTag cfg child = do
469 (e, eventTriggerRefs) <- readMVar wrapResult
480 (e, eventTriggerRefs) <- readMVar wrapResult
470 bracketOnError
481 bracketOnError
471 -- Run the setup, acquiring the cleanup action
482 -- Run the setup, acquiring the cleanup action
472− (triggerBody eventTriggerRefs e (WrapArg en) t)
483+ (triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t)
473 -- Run the cleanup, if we have it - but only when an exception is
484 -- Run the cleanup, if we have it - but only when an exception is
474 -- raised (we might get killed between acquiring the cleanup action
485 -- raised (we might get killed between acquiring the cleanup action
475 -- from 'triggerBody' and putting it in the MVar)
486 -- from 'triggerBody' and putting it in the MVar)
@@ -768,33 +779,73 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
768
779
769 {-# INLINABLE selectElement #-}
780 {-# INLINABLE selectElement #-}
770 selectElement cfg child = do
781 selectElement cfg child = do
771− ((e, result), _domElement') <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
782+ ((e, result), domElementRef) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
772− let domElement = undefined :: DOM.HTMLSelectElement
783+
773− let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
784+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
774− Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
785+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
775− v0 <- Select.getValue domSelectElement
786+
776− let getMyValue = Select.getValue domSelectElement
787+ (focusChange, triggerFocusChange) <- newTriggerEvent
777− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
788+
789+ doc <- askDocument
790+
791+ -- Expected initial value from config
792+ let v0 = _selectElementConfig_initialValue cfg
793+
794+ addHydrationStep $ do
795+ domElement <- liftIO $ readIORef domElementRef
796+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
797+ getValue = Select.getValue domSelectElement
798+
799+ -- The browser might have messed with the value, or the user could have
800+ -- altered it before activation, so we set it if it isn't what we expect
801+ liftJSM getValue >>= \v0' -> do
802+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
803+
804+ -- Watch for user interaction and trigger event accordingly
805+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)
806+
778− valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
807+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->
779− Nothing -> return never
780− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
808+ requestDomAction_ $ ffor eSetValue $ \v' -> do
781− Select.setValue domSelectElement v'
809+ Select.setValue domSelectElement v'
782− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
810+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
811+ liftIO $ triggerChangeBySetValue v
812+
813+ let focusChange' = leftmost
814+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
815+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
816+ ]
817+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
818+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
819+
820+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
821+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
822+
783 v <- holdDyn v0 $ leftmost
823 v <- holdDyn v0 $ leftmost
784 [ valueChangedBySetValue
824 [ valueChangedBySetValue
785 , valueChangedByUI
825 , valueChangedByUI
786 ]
826 ]
787− hasFocus <- mkHasFocus e
827+
788− let wrapped = SelectElement
828+ return $ flip (,) result $ SelectElement
789− { _selectElement_value = v
829+ { _selectElement_value = v
790− , _selectElement_change = valueChangedByUI
830+ , _selectElement_change = valueChangedByUI
791− , _selectElement_hasFocus = hasFocus
831+ , _selectElement_hasFocus = hasFocus
792− , _selectElement_element = e
832+ , _selectElement_element = e
793− , _selectElement_raw = domSelectElement
833+ , _selectElement_raw = undefined -- TODO domSelectElement
834+ }
835+
836+ placeRawElement e = getHydrationMode >>= \case
837+ HydrationMode_Immediate -> append $ toNode e
838+ HydrationMode_Hydrating -> addHydrationStep $ insertAfterPreviousNode e
839+ wrapRawElement e rawCfg = do
840+ ctx <- askJSM
841+ events <- askEvents
842+ let cfg = (def :: ElementConfig EventResult t GhcjsDomSpace)
843+ { _elementConfig_modifyAttributes = _rawElementConfig_modifyAttributes rawCfg
844+ , _elementConfig_eventSpec = _rawElementConfig_eventSpec rawCfg
794 }
845 }
795− return (wrapped, result)
846+ eventTriggerRefs <- wrap events e rawCfg
796− placeRawElement _ = return () -- append . toNode
847+ es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e
797− wrapRawElement e _ = return $ Element (EventSelector $ const never) e -- TODO
848+ return $ Element es e
798
849
799data FragmentState
850data FragmentState
800 = FragmentState_Unmounted
851 = FragmentState_Unmounted
@@ -842,7 +893,7 @@ instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjus
842 traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
893 traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
843 traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
894 traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
844
895
845−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ref m ~ IORef, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m) => Adjustable t (HydrationDomBuilderT t m) where
896+instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (HydrationDomBuilderT t m) where
846 {-# INLINABLE runWithReplace #-}
897 {-# INLINABLE runWithReplace #-}
847 runWithReplace a0 a' = do
898 runWithReplace a0 a' = do
848 initialEnv <- HydrationDomBuilderT ask
899 initialEnv <- HydrationDomBuilderT ask
@@ -932,15 +983,15 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
932 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
983 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
933 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
984 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
934 traverseDMapWithKeyWithAdjustWithMove = do
985 traverseDMapWithKeyWithAdjustWithMove = do
935− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
986+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseDMapChild t m k) v')) old = do
936− let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
987+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseDMapChild t m k) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
937 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
988 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
938− PatchDMapWithMove.From_Insert (Compose (_, _, _, sRef, _)) -> do
989+ PatchDMapWithMove.From_Insert (Compose (TraverseDMapChild (Right myTypeImmediate) _)) -> do
939− readIORef sRef >>= \case
990+ readIORef (_traverseDMapChildImmediate_childReadyState myTypeImmediate) >>= \case
940 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
991 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
941 ChildReadyState_Unready _ -> do
992 ChildReadyState_Unready _ -> do
942− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
993+ writeIORef (_traverseDMapChildImmediate_childReadyState myTypeImmediate) $ ChildReadyState_Unready $ Just $ Some.This k
943− return $ PatchDMapWithMove.From_Insert $ Constant sRef
994+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseDMapChildImmediate_childReadyState myTypeImmediate)
944 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
995 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
945 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
996 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
946 deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
997 deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
@@ -950,11 +1001,10 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
950 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
1001 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
951 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
1002 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
952 return $ applyAlways p' old
1003 return $ applyAlways p' old
953− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
1004+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseDMapChild t m k) v')) -> do
954 let p = unPatchDMapWithMove p_
1005 let p = unPatchDMapWithMove p_
955 phsBefore <- liftIO $ readIORef placeholders
1006 phsBefore <- liftIO $ readIORef placeholders
956− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
957− let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
1007+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseDMapChild t m k) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
958 collectIfMoved k e = do
1008 collectIfMoved k e = do
959 let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
1009 let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
960 nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
1010 nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
@@ -965,13 +1015,14 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
965 True -> do
1015 True -> do
966 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
1016 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
967 collected <- DMap.traverseWithKey collectIfMoved p
1017 collected <- DMap.traverseWithKey collectIfMoved p
968− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, _, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
1018+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (_traverseDMapChildImmediate_placeholder . error "FIXME" . _traverseDMapChild_mode . getCompose) p_) phsBefore --TODO: Don't recompute this
969− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
1019+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseDMapChild t m k) v') a -> JSM (Constant () a)
970 placeFragment k e = do
1020 placeFragment k e = do
971 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
1021 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
972 case PatchDMapWithMove._nodeInfo_from e of
1022 case PatchDMapWithMove._nodeInfo_from e of
973− PatchDMapWithMove.From_Insert (Compose (_, df, _, _, _)) -> do
1023+ PatchDMapWithMove.From_Insert (Compose (TraverseDMapChild x _)) -> case x of
1024+ Left _ -> pure ()
974− df `insertBefore` nextPlaceholder
1025+ Right immediate -> _traverseDMapChildImmediate_fragment immediate `insertBefore` nextPlaceholder
975 PatchDMapWithMove.From_Delete -> do
1026 PatchDMapWithMove.From_Delete -> do
976 return ()
1027 return ()
977 PatchDMapWithMove.From_Move fromKey -> do
1028 PatchDMapWithMove.From_Move fromKey -> do
@@ -983,40 +1034,54 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
983
1034
984{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
1035{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
985traverseDMapWithKeyWithAdjust'
1036traverseDMapWithKeyWithAdjust'
986− :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k)
1037+ :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k)
987 => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
1038 => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
988 -> DMap k v
1039 -> DMap k v
989 -> Event t (PatchDMap k v)
1040 -> Event t (PatchDMap k v)
990 -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
1041 -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
991traverseDMapWithKeyWithAdjust' = do
1042traverseDMapWithKeyWithAdjust' = do
992− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
1043+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseDMapChild t m k) v')) old = do
993− let new :: forall a. k a -> ComposeMaybe (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
1044+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseDMapChild t m k) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
994 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
1045 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
995 Nothing -> return Nothing
1046 Nothing -> return Nothing
996− Just (Compose (_, _, _, sRef, _)) -> do
1047+ Just (Compose (TraverseDMapChild (Left hydration) _)) -> pure Nothing
997− readIORef sRef >>= \case
1048+ Just (Compose (TraverseDMapChild (Right immediate) _)) -> do
1049+ readIORef (_traverseDMapChildImmediate_childReadyState immediate) >>= \case
998 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
1050 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
999 ChildReadyState_Unready _ -> do
1051 ChildReadyState_Unready _ -> do
1000− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1052+ writeIORef (_traverseDMapChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some.This k
1001− return $ Just $ Constant sRef
1053+ return $ Just $ Constant (_traverseDMapChildImmediate_childReadyState immediate)
1002 delete _ (Constant sRef) = do
1054 delete _ (Constant sRef) = do
1003 writeIORef sRef $ ChildReadyState_Unready Nothing
1055 writeIORef sRef $ ChildReadyState_Unready Nothing
1004 return $ Constant ()
1056 return $ Constant ()
1005 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
1057 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
1006 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
1058 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
1007 return $ applyAlways p' old
1059 return $ applyAlways p' old
1008− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1060+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
1009 phs <- liftIO $ readIORef placeholders
1061 phs <- liftIO $ readIORef placeholders
1010− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
1062+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
1011− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
1012 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
1063 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
1064+ -- Delete old node
1013− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
1065+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> do
1066+ thisPlaceholder `deleteUpTo` nextPlaceholder
1067+ -- Insert new node
1068+ forM_ mv $ \(Compose (TraverseDMapChild e _)) -> case e of
1069+ Left _hydration -> pure ()
1070+ Right immediate -> do
1014− forM_ mv $ \(Compose (_, df, _, _, _)) -> df `insertBefore` nextPlaceholder
1071+ _traverseDMapChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1072+ let weakened :: PatchMap (Some.Some k) (Either (TraverseDMapChildHydration t m) (TraverseDMapChildImmediate k))
1073+ weakened = weakenPatchDMapWith (_traverseDMapChild_mode . getCompose) $ PatchDMap patch
1074+ filtered :: PatchMap (Some.Some k) DOM.Text
1075+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case
1076+ Nothing -> Just Nothing -- deletion
1077+ Just (Left _) -> Nothing
1078+ Just (Right immediate) -> Just $ Just $ _traverseDMapChildImmediate_placeholder immediate
1079+ a = apply filtered phs
1015− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, _, ph, _, _)) -> ph) $ PatchDMap p) phs
1080+ liftIO $ writeIORef placeholders $! fromMaybe phs a
1016
1081
1017{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
1082{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
1018traverseIntMapWithKeyWithAdjust'
1083traverseIntMapWithKeyWithAdjust'
1019− :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m)
1084+ :: forall t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m)
1020 => (IntMap.Key -> v -> HydrationDomBuilderT t m v')
1085 => (IntMap.Key -> v -> HydrationDomBuilderT t m v')
1021 -> IntMap v
1086 -> IntMap v
1022 -> Event t (PatchIntMap v)
1087 -> Event t (PatchIntMap v)
@@ -1050,14 +1115,13 @@ traverseIntMapWithKeyWithAdjust' = do
1050{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1115{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1051hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1116hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1052 ( Adjustable t m
1117 ( Adjustable t m
1053− , MonadIO m
1118+ , MonadHold t m
1054 , MonadJSM m
1119 , MonadJSM m
1055 , MonadFix m
1120 , MonadFix m
1056 , PrimMonad m
1121 , PrimMonad m
1057 , Monoid (p (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1122 , Monoid (p (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1058 , Functor p
1123 , Functor p
1059 , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1124 , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1060− , MonadHold t m
1061 , Patch (p (HydrationRunnerT t m ()))
1125 , Patch (p (HydrationRunnerT t m ()))
1062 )
1126 )
1063 => ( (IntMap.Key -> v -> DomRenderHookT t m (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1127 => ( (IntMap.Key -> v -> DomRenderHookT t m (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
@@ -1072,7 +1136,6 @@ hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1072 -> Event t (p v)
1136 -> Event t (p v)
1073 -> HydrationDomBuilderT t m (IntMap v', Event t (p v'))
1137 -> HydrationDomBuilderT t m (IntMap v', Event t (p v'))
1074hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1138hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1075− (_hydrateStart, _, key) <- skipToReplaceStart
1076 initialEnv <- HydrationDomBuilderT ask
1139 initialEnv <- HydrationDomBuilderT ask
1077 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1140 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1078 pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
1141 pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
@@ -1139,7 +1202,6 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
1139 getHydrationMode >>= \case
1202 getHydrationMode >>= \case
1140 HydrationMode_Immediate -> void $ IntMap.traverseWithKey (\_ (_, df, _, _, _) -> void $ append $ toNode df) children0
1203 HydrationMode_Immediate -> void $ IntMap.traverseWithKey (\_ (_, df, _, _, _) -> void $ append $ toNode df) children0
1141 _ -> pure ()
1204 _ -> pure ()
1142− (_hydrateEnd, _lastPlaceholderRef) <- skipToReplaceEnd key
1143 requestDomAction_ $ ffor children' $ \p -> do
1205 requestDomAction_ $ ffor children' $ \p -> do
1144 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1206 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1145 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
1207 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1156,6 +1218,24 @@ insertAfterPreviousNode node = do
1156 Node.insertBefore_ parent node nextNode
1218 Node.insertBefore_ parent node nextNode
1157 setPreviousNode $ Just $ toNode node
1219 setPreviousNode $ Just $ toNode node
1158
1220
1221+data TraverseDMapChildImmediate k = TraverseDMapChildImmediate
1222+ { _traverseDMapChildImmediate_fragment :: DOM.DocumentFragment
1223+ -- ^ Child is appended to this fragment
1224+ , _traverseDMapChildImmediate_placeholder :: DOM.Text
1225+ -- ^ Placeholder reference
1226+ , _traverseDMapChildImmediate_childReadyState :: IORef (ChildReadyState k)
1227+ }
1228+
1229+newtype TraverseDMapChildHydration t m = TraverseDMapChildHydration
1230+ { _traverseDMapChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1231+ -- ^ Action to run at switchover, returns the placeholder
1232+ }
1233+
1234+data TraverseDMapChild t m k a = TraverseDMapChild
1235+ { _traverseDMapChild_mode :: Either (TraverseDMapChildHydration t m) (TraverseDMapChildImmediate k)
1236+ , _traverseDMapChild_result :: a
1237+ }
1238+
1159{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1239{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1160hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1240hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1161 ( Adjustable t m
1241 ( Adjustable t m
@@ -1166,35 +1246,39 @@ hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1166 , PrimMonad m
1246 , PrimMonad m
1167 , MonadFix m
1247 , MonadFix m
1168 , Patch (p k v)
1248 , Patch (p k v)
1169− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1170− , Patch (p k (Const (HydrationRunnerT t m ())))
1171− , PatchTarget (p k (Const (HydrationRunnerT t m ()))) ~ DMap k (Const (HydrationRunnerT t m ()))
1172− , Monoid (p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
1173 , Patch (p k (Constant Int))
1249 , Patch (p k (Constant Int))
1250+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1251+ , Patch (p k (Compose (TraverseDMapChild t m k) v'))
1252+ , PatchTarget (p k (Compose (TraverseDMapChild t m k) v')) ~ DMap k (Compose (TraverseDMapChild t m k) v')
1253+ , Monoid (p k (Compose (TraverseDMapChild t m k) v'))
1174 )
1254 )
1175 => (forall vv vv'.
1255 => (forall vv vv'.
1176 (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
1256 (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
1177 -> DMap k vv
1257 -> DMap k vv
1178 -> Event t (p k vv)
1258 -> Event t (p k vv)
1179 -> DomRenderHookT t m (DMap k vv', Event t (p k vv'))
1259 -> DomRenderHookT t m (DMap k vv', Event t (p k vv'))
1260+ )
1180− ) -- ^ The base monad's traversal
1261+ -- ^ The base monad's traversal
1181− -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
1262+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')
1263+ -- ^ A way of mapping over the patch type
1264+ -> (p k (Compose (TraverseDMapChild t m k) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k)))))
1182− -> (p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1265+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1183− -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
1266+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseDMapChild t m k) v') -> JSM ())
1267+ -- ^ Apply a patch to the DOM
1184 -> (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
1268 -> (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
1185 -> DMap k v
1269 -> DMap k v
1186 -> Event t (p k v)
1270 -> Event t (p k v)
1187 -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))
1271 -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))
1188hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
1272hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
1189−-- (hydrateStart, _, key) <- skipToReplaceStart -- TODO
1273+ doc <- askDocument
1190 initialEnv <- HydrationDomBuilderT ask
1274 initialEnv <- HydrationDomBuilderT ask
1191 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1275 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1192− pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
1276+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose (TraverseDMapChild t m k) v')) <- liftIO $ newIORef mempty
1193 haveEverBeenReady <- liftIO $ newIORef False
1277 haveEverBeenReady <- liftIO $ newIORef False
1194− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
1278+ placeholders <- liftIO $ newIORef Map.empty
1195− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1279+ lastPlaceholder <- createTextNode doc ("" :: Text)
1196 let applyDomUpdate p = do
1280 let applyDomUpdate p = do
1197− applyDomUpdate_ placeholders lastPlaceholderRef p
1281+ applyDomUpdate_ placeholders lastPlaceholder p
1198 markSelfReady
1282 markSelfReady
1199 liftIO $ writeIORef pendingChange $! mempty
1283 liftIO $ writeIORef pendingChange $! mempty
1200 markSelfReady = do
1284 markSelfReady = do
@@ -1221,38 +1305,36 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
1221 liftIO $ writeIORef pendingChange (newUnready, p)
1305 liftIO $ writeIORef pendingChange (newUnready, p)
1222 when (DMap.null newUnready) $ do
1306 when (DMap.null newUnready) $ do
1223 applyDomUpdate p
1307 applyDomUpdate p
1308+ (children0 :: DMap k (Compose (TraverseDMapChild t m k) v'), children' :: Event t (p k (Compose (TraverseDMapChild t m k) v')))
1224− (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1309+ <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1225− let processChild k (Compose (_, _, _, sRef, _)) = ComposeMaybe <$> do
1310+ let processChild k (Compose (TraverseDMapChild e _)) = case e of
1226− readIORef sRef >>= \case
1311+ Left _ -> pure $ ComposeMaybe Nothing
1312+ Right immediate -> ComposeMaybe <$> do
1313+ readIORef (_traverseDMapChildImmediate_childReadyState immediate) >>= \case
1227− ChildReadyState_Ready -> return Nothing
1314+ ChildReadyState_Ready -> return Nothing
1228− ChildReadyState_Unready _ -> do
1315+ ChildReadyState_Unready _ -> do
1229− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1316+ writeIORef (_traverseDMapChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some.This k
1230− return $ Just $ Constant sRef
1317+ return $ Just $ Constant (_traverseDMapChildImmediate_childReadyState immediate)
1231 initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1318 initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1232 liftIO $ if DMap.null initialUnready
1319 liftIO $ if DMap.null initialUnready
1233 then writeIORef haveEverBeenReady True
1320 then writeIORef haveEverBeenReady True
1234 else do
1321 else do
1235 modifyIORef' parentUnreadyChildren succ
1322 modifyIORef' parentUnreadyChildren succ
1236 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1323 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1237− let result0 = DMap.map (\(Compose (_, _, _, _, v)) -> v) children0
1238− placeholders0 = weakenDMapWith (\(Compose (_, _, ph, _, _)) -> ph) children0
1239− delayed0 :: DMap k (Const (HydrationRunnerT t m ()))
1240− delayed0 = DMap.map (\(Compose (delayed, _, _, _, _)) -> Const delayed) children0
1241− delayed' :: Event t (p k (Const (HydrationRunnerT t m ())))
1242− delayed' = ffor children' $ mapPatch $ \(Compose (d, _, _, _, _)) -> Const d
1243− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, _, r)) -> r
1244− doc <- askDocument
1245− let setFinalPlaceholder = do
1246− ph <- createTextNode doc ("" :: Text)
1247− insertAfterPreviousNode ph
1248− liftIO $ writeIORef lastPlaceholderRef ph
1249− addHydrationStepWithSetup (accumMaybeB (flip apply) delayed0 delayed') $ \delayed -> do
1250− _ <- join $ sample (traverse (\(_ :=> Const d) -> d) . DMap.toList <$> delayed)
1251− setFinalPlaceholder
1252− liftIO $ writeIORef placeholders $! placeholders0
1253 getHydrationMode >>= \case
1324 getHydrationMode >>= \case
1254− HydrationMode_Immediate -> void $ DMap.traverseWithKey (\_ (Compose (_, df, _, _, _)) -> Constant () <$ append (toNode df)) children0
1325+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1255− _ -> pure ()
1326+ dm :: DMap k (Compose (TraverseDMapChild t m k) v') <- sample $ currentIncremental children
1327+ phs <- traverse id $ weakenDMapWith (either _traverseDMapChildHydration_delayed (pure . _traverseDMapChildImmediate_placeholder) . _traverseDMapChild_mode . getCompose) dm
1328+ liftIO $ writeIORef placeholders $! phs
1329+ insertAfterPreviousNode lastPlaceholder
1330+ HydrationMode_Immediate -> do
1331+ let activate i = do
1332+ append $ toNode $ _traverseDMapChildImmediate_fragment i
1333+ pure $ _traverseDMapChildImmediate_placeholder i
1334+ phs <- traverse id $ weakenDMapWith ((either (error "delayed") activate) . _traverseDMapChild_mode . getCompose) children0
1335+ liftIO $ writeIORef placeholders $! phs
1336+ append $ toNode lastPlaceholder
1337+
1256 requestDomAction_ $ ffor children' $ \p -> do
1338 requestDomAction_ $ ffor children' $ \p -> do
1257 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1339 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1258 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
1340 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1260,6 +1342,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
1260 liftIO $ writeIORef pendingChange (newUnready, newP)
1342 liftIO $ writeIORef pendingChange (newUnready, newP)
1261 when (DMap.null newUnready) $ do
1343 when (DMap.null newUnready) $ do
1262 applyDomUpdate newP
1344 applyDomUpdate newP
1345+ let result0 = DMap.map (_traverseDMapChild_result . getCompose) children0
1346+ result' = ffor children' $ mapPatch $ _traverseDMapChild_result . getCompose
1263 return (result0, result')
1347 return (result0, result')
1264
1348
1265{-# INLINABLE drawChildUpdate #-}
1349{-# INLINABLE drawChildUpdate #-}
@@ -1267,35 +1351,47 @@ drawChildUpdate :: (MonadIO m, MonadJSM m, Reflex t)
1267 => HydrationDomBuilderEnv t
1351 => HydrationDomBuilderEnv t
1268 -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
1352 -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
1269 -> HydrationDomBuilderT t m (v' a)
1353 -> HydrationDomBuilderT t m (v' a)
1270− -> DomRenderHookT t m (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
1354+ -> DomRenderHookT t m (Compose (TraverseDMapChild t m k) v' a)
1271−drawChildUpdate initialEnv markReady child = do
1272− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
1273− let doc = _hydrationDomBuilderEnv_document initialEnv
1274− unreadyChildren <- liftIO $ newIORef 0
1275− hydrationMode <- liftIO $ readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv
1355+drawChildUpdate initialEnv markReady child = liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
1276− placeholder <- createTextNode doc ("" :: Text)
1277− (p, delayed) <- case hydrationMode of
1278− HydrationMode_Hydrating -> pure
1356+ HydrationMode_Hydrating -> do
1279− ( Left $ _hydrationDomBuilderEnv_parent initialEnv
1357+ let doc = _hydrationDomBuilderEnv_document initialEnv
1280− , insertAfterPreviousNode placeholder
1281− )
1282− HydrationMode_Immediate -> do
1283− df <- createDocumentFragment doc
1284− Node.appendChild_ df placeholder
1285− pure (Right df, pure ())
1286− p' <- either pure (liftIO . newIORef . toNode) p
1358+ unreadyChildren <- liftIO $ newIORef 0
1287− (result, finalState) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1359+ (result, childDelayed) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1288− { _hydrationDomBuilderEnv_parent = p'
1289− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1360+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1290− , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1361+ }
1362+ let delayed = do
1363+ placeholder <- createTextNode doc ("" :: Text)
1364+ insertAfterPreviousNode placeholder
1365+ pure placeholder
1366+ return $ Compose $ TraverseDMapChild
1367+ { _traverseDMapChild_result = result
1368+ , _traverseDMapChild_mode = Left TraverseDMapChildHydration
1369+ { _traverseDMapChildHydration_delayed = delayed <* childDelayed
1291 }
1370 }
1371+ }
1372+ HydrationMode_Immediate -> do
1373+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
1374+ let doc = _hydrationDomBuilderEnv_document initialEnv
1375+ unreadyChildren <- liftIO $ newIORef 0
1376+ df <- createDocumentFragment doc
1377+ placeholder <- createTextNode doc ("" :: Text)
1378+ Node.appendChild_ df placeholder
1379+ parentRef <- liftIO . newIORef $ toNode df
1380+ (result, _s) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1381+ { _hydrationDomBuilderEnv_parent = parentRef
1382+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1383+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1384+ }
1292− u <- liftIO $ readIORef unreadyChildren
1385+ u <- liftIO $ readIORef unreadyChildren
1293− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1386+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1294− return $ Compose
1387+ return $ Compose $ TraverseDMapChild
1295− ( delayed >> finalState
1388+ { _traverseDMapChild_result = result
1296− , either (const $ error "drawChildUpdate: Tried to use document fragment in hydration mode") id p
1389+ , _traverseDMapChild_mode = Right TraverseDMapChildImmediate
1297− , placeholder, childReadyState, result
1390+ { _traverseDMapChildImmediate_fragment = df
1298− )
1391+ , _traverseDMapChildImmediate_placeholder = placeholder
1392+ , _traverseDMapChildImmediate_childReadyState = childReadyState
1393+ }
1394+ }
1299
1395
1300{-# INLINABLE drawChildUpdateInt #-}
1396{-# INLINABLE drawChildUpdateInt #-}
1301drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
1397drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+1−4
@@ -174,6 +174,7 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m)
174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
176
176
177+-- TODO remove this?
177replaceStart :: (DomBuilder t m, MonadIO m) => m Text
178replaceStart :: (DomBuilder t m, MonadIO m) => m Text
178replaceStart = do
179replaceStart = do
179 str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')
180 str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')
@@ -203,7 +204,6 @@ hoistIntMapWithKeyWithAdjust :: forall t m p a b.
203 -> Event t (p a)
204 -> Event t (p a)
204 -> StaticDomBuilderT t m (IntMap b, Event t (p b))
205 -> StaticDomBuilderT t m (IntMap b, Event t (p b))
205hoistIntMapWithKeyWithAdjust base f im0 im' = do
206hoistIntMapWithKeyWithAdjust base f im0 im' = do
206− key <- replaceStart
207 e <- StaticDomBuilderT ask
207 e <- StaticDomBuilderT ask
208 (children0, children') <- lift $ base (\k v -> runStaticDomBuilderT (f k v) e) im0 im'
208 (children0, children') <- lift $ base (\k v -> runStaticDomBuilderT (f k v) e) im0 im'
209 let result0 = IntMap.map fst children0
209 let result0 = IntMap.map fst children0
@@ -217,7 +217,6 @@ hoistIntMapWithKeyWithAdjust base f im0 im' = do
217 os <- sample $ currentIncremental outputs
217 os <- sample $ currentIncremental outputs
218 fmap mconcat $ forM (IntMap.toList os) $ \(_, o) -> do
218 fmap mconcat $ forM (IntMap.toList os) $ \(_, o) -> do
219 sample o
219 sample o
220− replaceEnd key
221 return (result0, result')
220 return (result0, result')
222
221
223hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
222hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
@@ -239,7 +238,6 @@ hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
239 -> Event t (p k v)
238 -> Event t (p k v)
240 -> StaticDomBuilderT t m (DMap k v', Event t (p k v'))
239 -> StaticDomBuilderT t m (DMap k v', Event t (p k v'))
241hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do
240hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do
242−-- key <- replaceStart
243 e <- StaticDomBuilderT ask
241 e <- StaticDomBuilderT ask
244 (children0, children') <- lift $ base (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'
242 (children0, children') <- lift $ base (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'
245 let result0 = DMap.map (snd . getCompose) children0
243 let result0 = DMap.map (snd . getCompose) children0
@@ -253,7 +251,6 @@ hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do
253 os <- sample $ currentIncremental outputs
251 os <- sample $ currentIncremental outputs
254 fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do
252 fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do
255 sample o
253 sample o
256−-- replaceEnd key
257 return (result0, result')
254 return (result0, result')
258
255
259instance SupportsStaticDomBuilder t m => NotReady t (StaticDomBuilderT t m) where
256instance SupportsStaticDomBuilder t m => NotReady t (StaticDomBuilderT t m) where
reflex-dom-core/test/hydration.hs+553−55
@@ -2,65 +2,114 @@
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE GADTs #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
11
15
12import Control.Concurrent
16import Control.Concurrent
13−import Control.Lens ((^.))
14import Control.Monad
17import Control.Monad
15import Control.Monad.Catch
18import Control.Monad.Catch
16import Control.Monad.Fix
19import Control.Monad.Fix
17import Control.Monad.IO.Class
20import Control.Monad.IO.Class
18−import qualified Data.ByteString as BS
21+import Data.Constraint (Dict(..))
22+import Data.Constraint.Extras
23+import Data.Dependent.Map (DMap)
24+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
19import Data.Foldable (traverse_)
25import Data.Foldable (traverse_)
26+import Data.Functor.Identity
27+import Data.Functor.Misc
28+import Data.GADT.Compare.TH
29+import Data.GADT.Show.TH
20import Data.IORef
30import Data.IORef
21−import Data.Maybe (fromMaybe)
31+import Data.Map (Map)
32+import Data.Maybe (fromMaybe, fromJust)
22import Data.Proxy
33import Data.Proxy
23import Data.Text (Text)
34import Data.Text (Text)
24−import Language.Javascript.JSaddle (JSException(..), syncPoint, liftJSM, jsg, js1)
35+import Language.Javascript.JSaddle (syncPoint, liftJSM)
25import Language.Javascript.JSaddle.Warp
36import Language.Javascript.JSaddle.Warp
26import Network.HTTP.Types (status200)
37import Network.HTTP.Types (status200)
27import Network.Wai
38import Network.Wai
28import Network.WebSockets
39import Network.WebSockets
29−import Reflex.Dom.Core
30import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
40import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
41+import Reflex.Dom.Core
42+import System.Directory
43+import System.IO (stderr)
44+import System.IO.Silently
45+import System.IO.Temp
31import System.Process
46import System.Process
32−import System.Random
33import System.Timeout
47import System.Timeout
34−import Test.Hspec
35import Test.HUnit
48import Test.HUnit
49+import Test.Hspec
36import Test.WebDriver (WD)
50import Test.WebDriver (WD)
37−import qualified GHCJS.DOM.Types as DOM
38−import qualified GHCJS.DOM.File as File
39
51
40−--import System.IO.Silently
41−import System.IO.Temp
42−import System.Directory
43−import System.Process
44−import qualified System.FilePath as FilePath
45−
46−import qualified GHCJS.DOM.EventM as EventM
47−import qualified GHCJS.DOM.GlobalEventHandlers as Events
48import qualified Data.ByteString.Lazy as LBS
52import qualified Data.ByteString.Lazy as LBS
53+import qualified Data.Dependent.Map as DMap
49import qualified Data.Text as T
54import qualified Data.Text as T
50import qualified Data.Text.Encoding as TE
55import qualified Data.Text.Encoding as TE
51import Network.Socket
56import Network.Socket
57+import qualified GHCJS.DOM as DOM
58+import qualified GHCJS.DOM.Document as Document
59+import qualified GHCJS.DOM.Element as Element
60+import qualified GHCJS.DOM.EventM as EventM
61+import qualified GHCJS.DOM.File as File
62+import qualified GHCJS.DOM.GlobalEventHandlers as Events
63+import qualified GHCJS.DOM.Node as Node
64+import qualified GHCJS.DOM.Types as DOM
52import qualified Network.Wai.Handler.Warp as Warp
65import qualified Network.Wai.Handler.Warp as Warp
66+import qualified System.FilePath as FilePath
53import qualified Test.WebDriver as WD
67import qualified Test.WebDriver as WD
54
68
55testTimeLimit :: Int
69testTimeLimit :: Int
56−testTimeLimit = 1 * 1000 * 1000
70+testTimeLimit = 3 * 1000 * 1000
57
71
58chromeConfig :: Text -> WD.WDConfig
72chromeConfig :: Text -> WD.WDConfig
59chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
73chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
60
74
61−-- TODO list
75+keyMap :: DMap DKey Identity
62−-- use only available ports
76+keyMap = DMap.fromList
63−-- parallel (requires port fix)
77+ [ Key_Int ==> 0
78+ , Key_Char ==> 'A'
79+ ]
80+
81+data DKey a where
82+ Key_Int :: DKey Int
83+ Key_Char :: DKey Char
84+ Key_Bool :: DKey Bool
85+
86+instance ArgDict DKey where
87+ type ConstraintsFor DKey c = (c Int, c Char, c Bool)
88+ argDict = \case
89+ Key_Int -> Dict
90+ Key_Char -> Dict
91+ Key_Bool -> Dict
92+
93+textKey :: DKey a -> Text
94+textKey = \case
95+ Key_Int -> "Key_Int"
96+ Key_Char -> "Key_Char"
97+ Key_Bool -> "Key_Bool"
98+
99+deriveGEq ''DKey
100+deriveGCompare ''DKey
101+deriveGShow ''DKey
102+
103+instance ShowTag DKey Identity where
104+ showTaggedPrec = \case
105+ Key_Int -> showsPrec
106+ Key_Char -> showsPrec
107+ Key_Bool -> showsPrec
108+
109+instance EqTag DKey Identity where
110+ eqTagged Key_Int Key_Int = (==)
111+ eqTagged Key_Char Key_Char = (==)
112+ eqTagged Key_Bool Key_Bool = (==)
64
113
65main :: IO ()
114main :: IO ()
66main = withSeleniumServer $ \selenium ->
115main = withSeleniumServer $ \selenium ->
@@ -68,7 +117,7 @@ main = withSeleniumServer $ \selenium ->
68
117
69tests :: Selenium -> Spec
118tests :: Selenium -> Spec
70tests selenium = do
119tests selenium = do
71− describe "text" $ parallel $ do
120+ describe "text" $ do
72 it "works" $ do
121 it "works" $ do
73 testWidgetStatic (checkBodyText "hello world") $ do
122 testWidgetStatic (checkBodyText "hello world") $ do
74 text "hello world"
123 text "hello world"
@@ -134,8 +183,7 @@ tests selenium = do
134 testWidgetStatic (pure ()) $ do
183 testWidgetStatic (pure ()) $ do
135 text =<< prerender (pure "One") (pure "Two")
184 text =<< prerender (pure "One") (pure "Two")
136
185
137−
138− describe "element" $ parallel $ do
186+ describe "element" $ do
139 it "works with domEvent Click" $ do
187 it "works with domEvent Click" $ do
140 clickedRef <- newIORef False
188 clickedRef <- newIORef False
141 testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
189 testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
@@ -226,7 +274,7 @@ tests selenium = do
226 liftIO $ writeIORef clicked True
274 liftIO $ writeIORef clicked True
227 pure ()
275 pure ()
228
276
229− describe "inputElement" $ parallel $ do
277+ describe "inputElement" $ do
230 describe "hydration" $ do
278 describe "hydration" $ do
231 it "doesn't wipe user input when switching over" $ do
279 it "doesn't wipe user input when switching over" $ do
232 inputRef <- newIORef ""
280 inputRef <- newIORef ""
@@ -298,9 +346,7 @@ tests selenium = do
298 readIORef valueByUIRef >>= flip shouldBe "hello"
346 readIORef valueByUIRef >>= flip shouldBe "hello"
299 readIORef valueRef >>= flip shouldBe "world"
347 readIORef valueRef >>= flip shouldBe "world"
300 testWidget (pure ()) checkValue $ do
348 testWidget (pure ()) checkValue $ do
301− (setValue, triggerSetValue) <- newTriggerEvent
349+ setValue <- triggerEventWithChan setValueChan
302− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
303− triggerSetValue =<< readChan setValueChan
304 e <- inputElement $ def & inputElementConfig_setValue .~ setValue
350 e <- inputElement $ def & inputElementConfig_setValue .~ setValue
305 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e
351 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e
306 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
352 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -323,9 +369,7 @@ tests selenium = do
323 readIORef checkedByUIRef >>= flip shouldBe True
369 readIORef checkedByUIRef >>= flip shouldBe True
324 readIORef checkedRef >>= flip shouldBe False
370 readIORef checkedRef >>= flip shouldBe False
325 testWidget (pure ()) checkValue $ do
371 testWidget (pure ()) checkValue $ do
326− (setChecked, triggerSetChecked) <- newTriggerEvent
372+ setChecked <- triggerEventWithChan setCheckedChan
327− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
328− triggerSetChecked =<< readChan setCheckedChan
329 e <- inputElement $ def
373 e <- inputElement $ def
330 & initialAttributes .~ "type" =: "checkbox"
374 & initialAttributes .~ "type" =: "checkbox"
331 & inputElementConfig_setChecked .~ setChecked
375 & inputElementConfig_setChecked .~ setChecked
@@ -389,9 +433,7 @@ tests selenium = do
389 readIORef valueByUIRef >>= flip shouldBe "hello"
433 readIORef valueByUIRef >>= flip shouldBe "hello"
390 readIORef valueRef >>= flip shouldBe "world"
434 readIORef valueRef >>= flip shouldBe "world"
391 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
435 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
392− (setValue, triggerSetValue) <- newTriggerEvent
436+ setValue <- triggerEventWithChan setValueChan
393− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
394− triggerSetValue =<< readChan setValueChan
395 e <- inputElement $ def & inputElementConfig_setValue .~ setValue
437 e <- inputElement $ def & inputElementConfig_setValue .~ setValue
396 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e
438 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _inputElement_input e
397 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
439 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -414,9 +456,7 @@ tests selenium = do
414 readIORef checkedByUIRef >>= flip shouldBe True
456 readIORef checkedByUIRef >>= flip shouldBe True
415 readIORef checkedRef >>= flip shouldBe False
457 readIORef checkedRef >>= flip shouldBe False
416 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
458 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
417− (setChecked, triggerSetChecked) <- newTriggerEvent
459+ setChecked <- triggerEventWithChan setCheckedChan
418− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
419− triggerSetChecked =<< readChan setCheckedChan
420 e <- inputElement $ def
460 e <- inputElement $ def
421 & initialAttributes .~ "type" =: "checkbox"
461 & initialAttributes .~ "type" =: "checkbox"
422 & inputElementConfig_setChecked .~ setChecked
462 & inputElementConfig_setChecked .~ setChecked
@@ -439,7 +479,7 @@ tests selenium = do
439 names <- liftJSM $ traverse File.getName fs
479 names <- liftJSM $ traverse File.getName fs
440 liftIO $ writeIORef filesRef names
480 liftIO $ writeIORef filesRef names
441
481
442− describe "textAreaElement" $ parallel $ do
482+ describe "textAreaElement" $ do
443 describe "hydration" $ do
483 describe "hydration" $ do
444 it "doesn't wipe user input when switching over" $ do
484 it "doesn't wipe user input when switching over" $ do
445 inputRef <- newIORef ""
485 inputRef <- newIORef ""
@@ -511,9 +551,7 @@ tests selenium = do
511 readIORef valueByUIRef >>= flip shouldBe "hello"
551 readIORef valueByUIRef >>= flip shouldBe "hello"
512 readIORef valueRef >>= flip shouldBe "world"
552 readIORef valueRef >>= flip shouldBe "world"
513 testWidget (pure ()) checkValue $ do
553 testWidget (pure ()) checkValue $ do
514− (setValue', triggerSetValue) <- newTriggerEvent
554+ setValue' <- triggerEventWithChan setValueChan
515− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
516− triggerSetValue =<< readChan setValueChan
517 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
555 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
518 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _textAreaElement_input e
556 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _textAreaElement_input e
519 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
557 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
@@ -559,14 +597,223 @@ tests selenium = do
559 readIORef valueByUIRef >>= flip shouldBe "hello"
597 readIORef valueByUIRef >>= flip shouldBe "hello"
560 readIORef valueRef >>= flip shouldBe "world"
598 readIORef valueRef >>= flip shouldBe "world"
561 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
599 testWidget (pure ()) checkValue $ prerender (pure ()) $ do
562− (setValue', triggerSetValue) <- newTriggerEvent
600+ setValue' <- triggerEventWithChan setValueChan
563− prerender (pure ()) $ liftIO $ void $ forkIO $ forever $ do
564− triggerSetValue =<< readChan setValueChan
565 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
601 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
566 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _textAreaElement_input e
602 performEvent_ $ liftIO . writeIORef valueByUIRef <$> _textAreaElement_input e
567 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
603 performEvent_ $ liftIO . writeIORef valueRef <$> updated (value e)
568
604
569− describe "prerender" $ parallel $ do
605+ describe "selectElement" $ do
606+ let options :: DomBuilder t m => m ()
607+ options = do
608+ elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
609+ elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
610+ elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
611+ describe "hydration" $ do
612+ it "sets initial value correctly" $ do
613+ inputRef <- newIORef ""
614+ let setup = do
615+ e <- WD.findElem $ WD.ByTag "select"
616+ assertAttr e "value" (Just "three")
617+ WD.click <=< WD.findElem $ WD.ById "two"
618+ pure e
619+ check e = do
620+ assertAttr e "value" (Just "two")
621+ liftIO $ readIORef inputRef >>= (`shouldBe` "three")
622+ WD.click <=< WD.findElem $ WD.ByTag "button"
623+ assertAttr e "value" (Just "two")
624+ liftIO $ readIORef inputRef >>= (`shouldBe` "two")
625+ testWidget' setup check $ do
626+ (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
627+ click <- button "save"
628+ liftIO . writeIORef inputRef <=< sample $ current $ _selectElement_value e
629+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (_selectElement_value e)) click
630+ it "captures user input after switchover" $ do
631+ inputRef <- newIORef ""
632+ let checkValue = do
633+ e <- WD.findElem $ WD.ByTag "select"
634+ assertAttr e "value" (Just "one")
635+ WD.click <=< WD.findElem $ WD.ById "two"
636+ assertAttr e "value" (Just "two")
637+ WD.click <=< WD.findElem $ WD.ByTag "button"
638+ liftIO $ readIORef inputRef >>= (`shouldBe` "two")
639+ testWidget (pure ()) checkValue $ do
640+ (e, ()) <- selectElement def options
641+ click <- button "save"
642+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (_selectElement_value e)) click
643+ it "sets focus appropriately" $ do
644+ focusRef <- newIORef False
645+ let checkValue = do
646+ liftIO $ readIORef focusRef >>= flip shouldBe False
647+ e <- WD.findElem $ WD.ByTag "select"
648+ WD.click e
649+ liftIO $ threadDelay 100000
650+ liftIO $ readIORef focusRef >>= flip shouldBe True
651+ testWidget (pure ()) checkValue $ do
652+ (e, ()) <- selectElement def options
653+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_selectElement_hasFocus e)
654+ it "sets focus when focus occurs before hydration" $ do
655+ focusRef <- newIORef False
656+ let setup = do
657+ e <- WD.findElem $ WD.ByTag "select"
658+ WD.click e
659+ hasFocus <- (== e) <$> WD.activeElem
660+ liftIO $ do
661+ hasFocus `shouldBe` True
662+ readIORef focusRef >>= flip shouldBe False
663+ check = liftIO $ readIORef focusRef >>= flip shouldBe True
664+ testWidget setup check $ do
665+ (e, ()) <- selectElement def options
666+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_selectElement_hasFocus e)
667+ it "sets value appropriately" $ do
668+ valueByUIRef <- newIORef ("" :: Text)
669+ valueRef <- newIORef ("" :: Text)
670+ setValueChan :: Chan Text <- newChan
671+ let checkValue = do
672+ e <- WD.findElem $ WD.ByTag "select"
673+ assertAttr e "value" (Just "one")
674+ liftIO $ readIORef valueByUIRef >>= flip shouldBe "one"
675+ liftIO $ readIORef valueRef >>= flip shouldBe "one"
676+ WD.click <=< WD.findElem $ WD.ById "two"
677+ liftIO $ do
678+ threadDelay 100000
679+ readIORef valueByUIRef >>= flip shouldBe "two"
680+ readIORef valueRef >>= flip shouldBe "two"
681+ writeChan setValueChan "three"
682+ threadDelay 100000
683+ readIORef valueByUIRef >>= flip shouldBe "two"
684+ readIORef valueRef >>= flip shouldBe "three"
685+ testWidget (pure ()) checkValue $ do
686+ setValue' <- triggerEventWithChan setValueChan
687+ (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
688+ performEvent_ $ liftIO . writeIORef valueByUIRef <$> _selectElement_change e
689+ performEvent_ $ liftIO . writeIORef valueRef <$> updated (_selectElement_value e)
690+
691+ describe "hydration/immediate" $ do
692+ it "captures user input after switchover" $ do
693+ inputRef :: IORef Text <- newIORef ""
694+ let checkValue = do
695+ WD.click <=< WD.findElem $ WD.ById "two"
696+ WD.click <=< WD.findElem $ WD.ByTag "button"
697+ liftIO $ readIORef inputRef >>= flip shouldBe "two"
698+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do
699+ (e, ()) <- selectElement def options
700+ click <- button "save"
701+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (_selectElement_value e)) click
702+ it "sets focus appropriately" $ do
703+ focusRef <- newIORef False
704+ let checkValue = do
705+ liftIO $ readIORef focusRef >>= flip shouldBe False
706+ e <- WD.findElem $ WD.ByTag "select"
707+ WD.click e
708+ liftIO $ threadDelay 100000
709+ liftIO $ readIORef focusRef >>= flip shouldBe True
710+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do
711+ (e, ()) <- selectElement def options
712+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_selectElement_hasFocus e)
713+ it "sets value appropriately" $ do
714+ valueByUIRef :: IORef Text <- newIORef ""
715+ valueRef :: IORef Text <- newIORef ""
716+ setValueChan :: Chan Text <- newChan
717+ let checkValue = do
718+ liftIO $ readIORef valueByUIRef >>= flip shouldBe "one"
719+ liftIO $ readIORef valueRef >>= flip shouldBe "one"
720+ WD.click <=< WD.findElem $ WD.ById "two"
721+ liftIO $ do
722+ threadDelay 100000
723+ readIORef valueByUIRef >>= flip shouldBe "two"
724+ readIORef valueRef >>= flip shouldBe "two"
725+ writeChan setValueChan "three"
726+ threadDelay 100000
727+ readIORef valueByUIRef >>= flip shouldBe "two"
728+ readIORef valueRef >>= flip shouldBe "three"
729+ testWidget (pure ()) checkValue $ prerender (pure ()) $ do
730+ setValue' <- triggerEventWithChan setValueChan
731+ (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
732+ performEvent_ $ liftIO . writeIORef valueByUIRef <$> _selectElement_change e
733+ performEvent_ $ liftIO . writeIORef valueRef <$> updated (_selectElement_value e)
734+
735+ let createRawElement :: DOM.MonadJSM m => m DOM.Element
736+ createRawElement = do
737+ doc <- DOM.currentDocumentUnchecked
738+ div <- Document.createElement doc ("div" :: Text)
739+ Element.setAttribute div ("id" :: Text) ("raw" :: Text)
740+ text <- Document.createTextNode doc ("two" :: Text)
741+ Node.appendChild div text
742+ pure div
743+ describe "placeRawElement" $ do
744+ let checkOrder = do
745+ shouldContainText "two" <=< WD.findElem $ WD.ByTag "div"
746+ shouldContainText "one\ntwo\nthree" <=< WD.findElem $ WD.ByTag "body"
747+ it "is placed correctly in the DOM at switchover" $ do
748+ testWidget (pure ()) checkOrder $ do
749+ text "one"
750+ prerender (pure ()) $ placeRawElement =<< createRawElement
751+ text "three"
752+ it "is placed correctly in the DOM in immediate mode" $ do
753+ testWidget (pure ()) checkOrder $ prerender (pure ()) $ do
754+ text "one"
755+ placeRawElement =<< createRawElement
756+ text "three"
757+ it "is placed correctly in the DOM in hydration mode" $ do
758+ testWidget (pure ()) checkOrder $ do
759+ text "one"
760+ mElement <- prerender (pure Nothing) $ Just <$> createRawElement
761+ traverse_ placeRawElement mElement
762+ text "three"
763+ it "can be clicked" $ do
764+ clickedRef <- newIORef False
765+ let check = WD.click <=< WD.findElem $ WD.ByTag "div"
766+ testWidget (pure ()) check $ prerender (pure ()) $ do
767+ raw <- createRawElement
768+ placeRawElement raw
769+ let htmlElement = DOM.uncheckedCastTo DOM.HTMLElement raw
770+ liftJSM $ htmlElement `EventM.on` Events.click $ do
771+ liftIO $ writeIORef clickedRef True
772+ return ()
773+ clicked <- readIORef clickedRef
774+ assertEqual "Not clicked" True clicked
775+
776+ describe "wrapRawElement" $ do
777+ it "modifies attributes" $ do
778+ modifyAttrsChan :: Chan (Map AttributeName (Maybe Text)) <- newChan
779+ let check = do
780+ div <- WD.findElem $ WD.ByTag "div"
781+ assertAttr div "test" Nothing
782+ liftIO $ writeChan modifyAttrsChan ("test" =: Just "test")
783+ assertAttr div "test" (Just "test")
784+ testWidget (pure ()) check $ prerender (pure ()) $ do
785+ modifyAttrs <- triggerEventWithChan modifyAttrsChan
786+ raw <- createRawElement
787+ placeRawElement raw
788+ wrapRawElement raw $ RawElementConfig
789+ { _rawElementConfig_modifyAttributes = Just modifyAttrs
790+ , _rawElementConfig_eventSpec = (def :: EventSpec GhcjsDomSpace EventResult)
791+ }
792+ return ()
793+ it "works with eventFlags" $ do
794+ clickedRef <- newIORef False
795+ let clickBoth = do
796+ liftIO $ readIORef clickedRef >>= flip shouldBe False
797+ WD.findElem (WD.ById "normal") >>= WD.click
798+ liftIO $ do
799+ readIORef clickedRef >>= flip shouldBe True
800+ writeIORef clickedRef False
801+ WD.findElem (WD.ById "raw") >>= WD.click
802+ liftIO $ do
803+ threadDelay 100000
804+ readIORef clickedRef >>= flip shouldBe False
805+ testWidget (pure ()) clickBoth $ prerender (pure ()) $ do
806+ (e, _) <- el' "div" $ do
807+ raw <- createRawElement
808+ placeRawElement raw
809+ wrapRawElement raw $ RawElementConfig
810+ { _rawElementConfig_modifyAttributes = Nothing
811+ , _rawElementConfig_eventSpec = addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> stopPropagation) (def :: EventSpec GhcjsDomSpace EventResult)
812+ }
813+ elAttr "div" ("id" =: "normal") $ text "normal"
814+ performEvent_ $ liftIO (writeIORef clickedRef True) <$ domEvent Click e
815+
816+ describe "prerender" $ do
570 it "works in simple case" $ do
817 it "works in simple case" $ do
571 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
818 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
572 prerender (text "One") (text "Two")
819 prerender (text "One") (text "Two")
@@ -597,6 +844,240 @@ tests selenium = do
597 )
844 )
598 (traverse_ elementShouldBeRemoved)
845 (traverse_ elementShouldBeRemoved)
599 (el "span" $ prerender (text "One") (text "Two"))
846 (el "span" $ prerender (text "One") (text "Two"))
847+-- it "postBuild works on server side" $ do
848+-- pbRef <- newIORef False
849+-- testWidgetStatic (pure ()) $ do
850+-- prerender (do
851+-- pb <- getPostBuild
852+-- performEvent_ $ liftIO (writeIORef pbRef True) <$ pb) blank
853+-- readIORef pbRef >>= (`shouldBe` True)
854+ it "postBuild works on client side" $ do
855+ pbRef <- newIORef False
856+ testWidgetStatic (pure ()) $ do
857+ prerender blank $ do
858+ pb <- getPostBuild
859+ performEvent_ $ liftIO (writeIORef pbRef True) <$ pb
860+ readIORef pbRef >>= (`shouldBe` True)
861+
862+ describe "runWithReplace" $ do
863+ it "works" $ do
864+ replaceChan <- newChan
865+ let setup = WD.findElem $ WD.ByTag "div"
866+ check ssr = do
867+ -- Check that the original element still exists and has the correct text
868+ WD.getText ssr >>= liftIO . flip shouldBe "two"
869+ liftIO $ do
870+ writeChan replaceChan "three"
871+ threadDelay 100000
872+ elementShouldBeRemoved ssr
873+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
874+ testWidget' setup check $ do
875+ replace <- triggerEventWithChan replaceChan
876+ pb <- getPostBuild
877+ runWithReplace (el "div" $ text "one") $ leftmost
878+ [ el "div" (text "two") <$ pb
879+ , el "span" . text <$> replace
880+ ]
881+ return ()
882+ it "can be nested in initial widget" $ do
883+ replaceChan <- newChan
884+ let setup = WD.findElem $ WD.ByTag "div"
885+ check ssr = do
886+ -- Check that the original element still exists and has the correct text
887+ WD.getText ssr >>= liftIO . flip shouldBe "two"
888+ liftIO $ do
889+ writeChan replaceChan "three"
890+ threadDelay 100000
891+ elementShouldBeRemoved ssr
892+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
893+ testWidget' setup check $ void $ flip runWithReplace never $ do
894+ replace <- triggerEventWithChan replaceChan
895+ pb <- getPostBuild
896+ runWithReplace (el "div" $ text "one") $ leftmost
897+ [ el "div" (text "two") <$ pb
898+ , el "span" . text <$> replace
899+ ]
900+ return ()
901+ it "can be nested in postBuild widget" $ do
902+ replaceChan <- newChan
903+ let setup = WD.findElem $ WD.ByTag "div"
904+ check ssr = do
905+ -- Check that the original element still exists and has the correct text
906+ WD.getText ssr >>= liftIO . flip shouldBe "two"
907+ liftIO $ do
908+ writeChan replaceChan "three"
909+ threadDelay 100000
910+ elementShouldBeRemoved ssr
911+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
912+ testWidget' setup check $ void $ do
913+ pb <- getPostBuild
914+ runWithReplace (pure ()) $ ffor pb $ \() -> do
915+ replace <- triggerEventWithChan replaceChan
916+ pb <- getPostBuild
917+ runWithReplace (el "div" $ text "one") $ leftmost
918+ [ el "div" (text "two") <$ pb
919+ , el "span" . text <$> replace
920+ ]
921+ return ()
922+ it "can be nested in event widget" $ do
923+ replaceChan1 <- newChan
924+ replaceChan2 <- newChan
925+ let check = do
926+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
927+ liftIO $ do
928+ writeChan replaceChan1 "one"
929+ threadDelay 100000
930+ one <- WD.findElem $ WD.ByTag "div"
931+ WD.getText one >>= liftIO . flip shouldBe "pb"
932+ liftIO $ do
933+ writeChan replaceChan2 "two"
934+ threadDelay 100000
935+ elementShouldBeRemoved one
936+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
937+ testWidget (pure ()) check $ void $ do
938+ replace1 <- triggerEventWithChan replaceChan1
939+ runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
940+ replace2 <- triggerEventWithChan replaceChan2
941+ pb <- getPostBuild
942+ runWithReplace (el "div" $ text r1) $ leftmost
943+ [ el "span" . text <$> replace2
944+ , el "div" (text "pb") <$ pb
945+ ]
946+ return ()
947+ it "works in immediate mode (RHS of prerender)" $ do
948+ replaceChan :: Chan Text <- newChan
949+ let check = do
950+ one <- WD.findElem $ WD.ByTag "div"
951+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
952+ WD.getText one >>= liftIO . flip shouldBe "one"
953+ liftIO $ do
954+ writeChan replaceChan "pb"
955+ threadDelay 100000
956+ elementShouldBeRemoved one
957+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
958+ testWidget (pure ()) check $ void $ do
959+ prerender blank $ do
960+ replace <- triggerEventWithChan replaceChan
961+ pb <- getPostBuild
962+ void $ runWithReplace (el "div" $ text "one") $ el "span" . text <$> replace
963+ it "works with postBuild in immediate mode (RHS of prerender)" $ do
964+ replaceChan :: Chan Text <- newChan
965+ let check = do
966+ two <- WD.findElem $ WD.ByTag "div"
967+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
968+ WD.getText two >>= liftIO . flip shouldBe "two"
969+ liftIO $ do
970+ writeChan replaceChan "three"
971+ threadDelay 100000
972+ elementShouldBeRemoved two
973+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
974+ testWidget (pure ()) check $ void $ do
975+ prerender blank $ do
976+ replace <- triggerEventWithChan replaceChan
977+ pb <- getPostBuild
978+ void $ runWithReplace (el "div" $ text "one") $ leftmost
979+ [ el "div" (text "two") <$ pb
980+ , el "span" . text <$> replace
981+ ]
982+
983+ describe "traverseDMapWithKeyWithAdjust" $ do
984+ let widget :: TestWidget js t m => DKey a -> Identity a -> m (Identity a)
985+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
986+ elClass "span" "key" $ text $ textKey k
987+ elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
988+ pure (Identity v)
989+ checkItem :: WD.Element -> Text -> Text -> WD ()
990+ checkItem li k v = do
991+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
992+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
993+ checkInitialItems dm xs = do
994+ liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
995+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
996+ getAndCheckInitialItems dm = do
997+ xs <- WD.findElems (WD.ByTag "li")
998+ checkInitialItems dm xs
999+ pure xs
1000+ checkRemoval chan k = do
1001+ e <- WD.findElem (WD.ById $ textKey k)
1002+ liftIO $ do
1003+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
1004+ threadDelay 100000
1005+ elementShouldBeRemoved e
1006+ checkReplace chan k v = do
1007+ e <- WD.findElem (WD.ById $ textKey k)
1008+ liftIO $ do
1009+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1010+ threadDelay 100000
1011+ elementShouldBeRemoved e
1012+ e' <- WD.findElem (WD.ById $ textKey k)
1013+ checkItem e' (textKey k) (T.pack $ show v)
1014+ checkInsert chan k v = do
1015+ liftIO $ do
1016+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1017+ threadDelay 100000
1018+ e <- WD.findElem (WD.ById $ textKey k)
1019+ checkItem e (textKey k) (T.pack $ show v)
1020+ postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1021+ it "doesn't replace elements at switchover, can delete/update/insert" $ do
1022+ chan <- newChan
1023+ let static = getAndCheckInitialItems keyMap
1024+ check xs = do
1025+ checkInitialItems keyMap xs
1026+ checkRemoval chan Key_Int
1027+ checkReplace chan Key_Char 'B'
1028+ checkInsert chan Key_Bool True
1029+ testWidget' static check $ void $ do
1030+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1031+ liftIO $ dmap `shouldBe` keyMap
1032+ it "handles postBuild correctly" $ do
1033+ chan <- newChan
1034+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1035+ check xs = do
1036+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
1037+ checkRemoval chan Key_Int
1038+ checkInsert chan Key_Char 'B'
1039+ checkReplace chan Key_Bool True
1040+ testWidget' static check $ void $ do
1041+ pb <- getPostBuild
1042+ replace <- triggerEventWithChan chan
1043+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1044+ liftIO $ dmap `shouldBe` keyMap
1045+ it "can delete/update/insert when built in prerender" $ do
1046+ chan <- newChan
1047+ let check = do
1048+ getAndCheckInitialItems keyMap
1049+ checkRemoval chan Key_Int
1050+ checkReplace chan Key_Char 'B'
1051+ checkInsert chan Key_Bool True
1052+ testWidget (pure ()) check $ prerender (pure ()) $ void $ do
1053+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1054+ liftIO $ dmap `shouldBe` keyMap
1055+ it "can delete/update/insert when built in immediate mode" $ do
1056+ chan <- newChan
1057+ let check = do
1058+ getAndCheckInitialItems keyMap
1059+ checkRemoval chan Key_Int
1060+ checkReplace chan Key_Char 'B'
1061+ checkInsert chan Key_Bool True
1062+ testWidget (pure ()) check $ void $ do
1063+ pb <- getPostBuild
1064+ runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1065+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1066+ liftIO $ dmap `shouldBe` keyMap
1067+ -- Should be fixed by prerender changes!
1068+ it "handles postBuild correctly in prerender" $ do
1069+ chan <- newChan
1070+ let check = do
1071+ getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1072+ checkRemoval chan Key_Int
1073+ checkInsert chan Key_Char 'B'
1074+ checkReplace chan Key_Bool True
1075+ testWidget (pure ()) check $ do
1076+ replace <- triggerEventWithChan chan
1077+ prerender (pure ()) $ void $ do
1078+ pb <- getPostBuild
1079+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1080+ liftIO $ dmap `shouldBe` keyMap
600
1081
601data Selenium = Selenium
1082data Selenium = Selenium
602 { _selenium_portNumber :: PortNumber
1083 { _selenium_portNumber :: PortNumber
@@ -608,6 +1089,7 @@ startSeleniumServer port = do
608 (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
1089 (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
609 { std_in = NoStream
1090 { std_in = NoStream
610 , std_out = NoStream
1091 , std_out = NoStream
1092+ , std_err = NoStream
611 }
1093 }
612 return $ terminateProcess ph
1094 return $ terminateProcess ph
613
1095
@@ -621,6 +1103,12 @@ withSeleniumServer f = do
621 , _selenium_stopServer = stopServer
1103 , _selenium_stopServer = stopServer
622 }
1104 }
623
1105
1106+triggerEventWithChan :: (TriggerEvent t m, Prerender js m) => Chan a -> m (Event t a)
1107+triggerEventWithChan chan = do
1108+ (e, trigger) <- newTriggerEvent
1109+ prerender (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
1110+ pure e
1111+
624assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
1112assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
625assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
1113assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
626
1114
@@ -631,26 +1119,22 @@ elementShouldBeRemoved e = do
631 Left e -> throwM e
1119 Left e -> throwM e
632 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
1120 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
633
1121
634−shouldContainText :: WD.Element -> Text -> WD ()
1122+shouldContainText :: Text -> WD.Element -> WD ()
635−shouldContainText e t = liftIO . flip shouldBe t =<< WD.getText e
1123+shouldContainText t = liftIO . flip shouldBe t <=< WD.getText
636
1124
637checkBodyText :: Text -> WD ()
1125checkBodyText :: Text -> WD ()
638checkBodyText = checkTextInTag "body"
1126checkBodyText = checkTextInTag "body"
639
1127
640checkTextInTag :: Text -> Text -> WD ()
1128checkTextInTag :: Text -> Text -> WD ()
641−checkTextInTag tag expected = do
1129+checkTextInTag tag expected = WD.findElem (WD.ByTag tag) >>= shouldContainText expected
642− body <- WD.findElem $ WD.ByTag tag
643− body `shouldContainText` expected
644
1130
645checkTextInId :: Text -> Text -> WD ()
1131checkTextInId :: Text -> Text -> WD ()
646−checkTextInId i expected = do
647− e <- WD.findElem $ WD.ById i
648− e `shouldContainText` expected
1132+checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
649
1133
650divId :: DomBuilder t m => Text -> m a -> m a
1134divId :: DomBuilder t m => Text -> m a -> m a
651divId i = elAttr "div" ("id" =: i)
1135divId i = elAttr "div" ("id" =: i)
652
1136
653−type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m, MonadIO m)
1137+type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadFix m, MonadIO m)
654
1138
655testWidgetStatic
1139testWidgetStatic
656 :: WD b
1140 :: WD b
@@ -697,7 +1181,7 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")
697 port <- getFreePort
1181 port <- getFreePort
698 let settings = Warp.setPort (fromIntegral $ toInteger port) Warp.defaultSettings
1182 let settings = Warp.setPort (fromIntegral $ toInteger port) Warp.defaultSettings
699 -- hSilence to get rid of ConnectionClosed logs
1183 -- hSilence to get rid of ConnectionClosed logs
700− jsaddleWarp = forkIO $ Warp.runSettings settings application
1184+ jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
701 bracket jsaddleWarp killThread $ \_ -> do
1185 bracket jsaddleWarp killThread $ \_ -> do
702 browserPath <- T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
1186 browserPath <- T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
703 when (T.null browserPath) $ fail "No browser was found"
1187 when (T.null browserPath) $ fail "No browser was found"
@@ -719,3 +1203,17 @@ getFreePort = liftIO $ withSocketsDo $ do
719 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1203 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
720 bind sock (addrAddress addr)
1204 bind sock (addrAddress addr)
721 return sock
1205 return sock
1206+
1207+testWidgetDebug :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> IO ()
1208+testWidgetDebug bodyWidget = do
1209+ let staticApp = do
1210+ el "head" $ pure ()
1211+ el "body" $ do
1212+ bodyWidget
1213+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1214+ ((), html) <- renderStatic staticApp
1215+ let entryPoint = do
1216+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) $ bodyWidget
1217+ syncPoint
1218+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1219+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application