reflex-dom-core 0.4 → 0.5

raw patch · 14 files changed

+4665/−1696 lines, 14 filesdep +HUnitdep +chrome-test-utilsdep +constraints-extrasdep −linux-namespacesdep ~aesondep ~basedep ~bytestringnew-uploader

Dependencies added: HUnit, chrome-test-utils, constraints-extras, exceptions, filepath, hspec, hspec-webdriver, http-types, lifted-base, network, random, silently, wai, wai-websockets, warp, webdriver, websockets

Dependencies removed: linux-namespaces

Dependency ranges changed: aeson, base, bytestring, constraints, containers, dependent-map, dependent-sum, dependent-sum-template, directory, ghcjs-dom, jsaddle, lens, ref-tf, reflex, text, unix

Files

• ChangeLog.md +7/−0
• reflex-dom-core.cabal +55/−7
• src/Reflex/Dom/Builder/Class.hs +53/−3
• src/Reflex/Dom/Builder/Immediate.hs +2625/−1544
• src/Reflex/Dom/Builder/Static.hs +72/−4
• src/Reflex/Dom/Core.hs +1/−0
• src/Reflex/Dom/Location.hs +39/−0
• src/Reflex/Dom/Main.hs +129/−17
• src/Reflex/Dom/Prerender.hs +182/−48
• src/Reflex/Dom/Specializations.hs +0/−62
• src/Reflex/Dom/Widget/Basic.hs +15/−0
• src/Reflex/Dom/Xhr/FormData.hs +47/−0
• test/gc.hs +12/−11
• test/hydration.hs +1428/−0

@@ -0,0 +1,7 @@+# Revision history for reflex-dom-core++## 0.5++* Add HydrationDomBuilderT to support hydration of statically rendered DOM nodes. See the note at the top of Reflex.Dom.Builder.Immediate.+* As a result of the hydration changes, the Prerender class has changed, the type of `prerender` has changed and it is now a class method.+* Add the Reflex.Dom.Xhr.FormData module to make posting formdata over xhr more convenient.

@@ -1,5 +1,5 @@ Name: reflex-dom-core-Version: 0.4+Version: 0.5 Synopsis: Functional Reactive Web Apps with Reflex Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine License: BSD3@@ -17,6 +17,7 @@                     src/Reflex/Dom/WebSocket/Foreign.hs                     src/Reflex/Dom/Xhr/ResponseType.hs                     src/Reflex/Dom/Xhr/Exception.hs+                    ChangeLog.md  flag use-template-haskell   description: Use template haskell to generate lenses@@ -64,8 +65,9 @@     monad-control >= 1.0.1 && < 1.1,     mtl >= 2.1 && < 2.3,     primitive >= 0.5 && < 0.7,+    random,     ref-tf == 0.4.*,-    reflex == 0.5.*,+    reflex == 0.6.*,     semigroups >= 0.16 && < 0.19,     stm == 2.4.*,     text == 1.2.*,@@ -100,7 +102,6 @@     Reflex.Dom.Modals.Class     Reflex.Dom.Old     Reflex.Dom.Prerender-    Reflex.Dom.Specializations     Reflex.Dom.Time     Reflex.Dom.WebSocket     Reflex.Dom.WebSocket.Query@@ -110,6 +111,7 @@     Reflex.Dom.Widget.Lazy     Reflex.Dom.Widget.Resize     Reflex.Dom.Xhr+    Reflex.Dom.Xhr.FormData   other-modules:     Foreign.JavaScript.Internal.Utils     Reflex.Dom.WebSocket.Foreign@@ -148,16 +150,62 @@   main-is: hlint.hs   type: exitcode-stdio-1.0 -test-suite gc+test-suite hydration   build-depends: base+               , aeson+               , bytestring+               , chrome-test-utils+               , constraints+               , constraints-extras+               , containers+               , dependent-map+               , dependent-sum+               , dependent-sum-template+               , directory+               , exceptions+               , filepath+               , ghcjs-dom+               , hspec+               , hspec-webdriver+               , http-types+               , HUnit+               , jsaddle+               , jsaddle-warp+               , lens+               , lifted-base+               , network+               , random+               , ref-tf                , reflex                , reflex-dom-core+               , process+               , silently+               , temporary+               , text+               , wai+               , wai-websockets+               , warp+               , webdriver+               , websockets+  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+  main-is: hydration.hs+  type: exitcode-stdio-1.0+  if !os(linux) || !arch(x86_64) || flag(profile-reflex)+    buildable: False++-- broken test on base 4.11 & ghc 8.4.3+-- needs to be updated for changes in GHC.Stats+test-suite gc+  build-depends: base+               , chrome-test-utils                , jsaddle                , jsaddle-warp-               , linux-namespaces                , process-               , temporary-               , unix+               , reflex+               , reflex-dom-core+               , text   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

@@ -35,6 +35,7 @@ #ifdef USE_TEMPLATE_HASKELL import Reflex.Dom.Builder.Class.TH #endif+import Reflex.BehaviorWriter.Base import Reflex.DynamicWriter.Base import Reflex.EventWriter.Base import Reflex.NotReady.Class@@ -61,13 +62,14 @@ import Data.Text (Text) import Data.Type.Coercion import GHCJS.DOM.Types (JSM)+import qualified GHCJS.DOM.Types as DOM  class Default (EventSpec d EventResult) => DomSpace d where   type EventSpec d :: (EventTag -> *) -> *   type RawDocument d :: *   type RawTextNode d :: *+  type RawCommentNode d :: *   type RawElement d :: *-  type RawFile d :: *   type RawInputElement d :: *   type RawTextAreaElement d :: *   type RawSelectElement d :: *@@ -86,6 +88,15 @@                    => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)   textNode = lift . textNode   {-# INLINABLE textNode #-}+  commentNode :: CommentNodeConfig t -> m (CommentNode (DomBuilderSpace m) t)+  default commentNode :: ( MonadTrans f+                      , m ~ f m'+                      , DomBuilderSpace m' ~ DomBuilderSpace m+                      , DomBuilder t m'+                      )+                   => CommentNodeConfig t -> m (CommentNode (DomBuilderSpace m) t)+  commentNode = lift . commentNode+  {-# INLINABLE commentNode #-}   element :: Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)   default element :: ( MonadTransControl f                      , StT f a ~ a@@ -175,6 +186,28 @@   { _textNode_raw :: RawTextNode d   } +data CommentNodeConfig t+   = CommentNodeConfig { _commentNodeConfig_initialContents :: {-# UNPACK #-} !Text+                       , _commentNodeConfig_setContents :: !(Maybe (Event t Text))+                       }++#ifndef USE_TEMPLATE_HASKELL+commentNodeConfig_initialContents :: Lens' (CommentNodeConfig t) Text+commentNodeConfig_initialContents f (CommentNodeConfig a b) = (\a' -> CommentNodeConfig a' b) <$> f a+{-# INLINE commentNodeConfig_initialContents #-}+#endif++instance (Reflex t) => Default (CommentNodeConfig t) where+  {-# INLINABLE def #-}+  def = CommentNodeConfig+    { _commentNodeConfig_initialContents = mempty+    , _commentNodeConfig_setContents = Nothing+    }++newtype CommentNode d t = CommentNode+  { _commentNode_raw :: RawCommentNode d+  }+ data AttributeName = AttributeName !(Maybe Namespace) !Text deriving (Show, Read, Eq, Ord)  mapKeysToAttributeName :: Map Text v -> Map AttributeName v@@ -291,7 +324,7 @@                   , _inputElement_hasFocus :: Dynamic t Bool                   , _inputElement_element :: Element er d t                   , _inputElement_raw :: RawInputElement d-                  , _inputElement_files :: Dynamic t [RawFile d]+                  , _inputElement_files :: Dynamic t [DOM.File]                   }  data TextAreaElementConfig er t m@@ -393,6 +426,7 @@ #ifdef USE_TEMPLATE_HASKELL concat <$> mapM (uncurry makeLensesWithoutField)   [ (["_textNodeConfig_setContents"], ''TextNodeConfig)+  , (["_commentNodeConfig_setContents"], ''CommentNodeConfig)   , ([ "_inputElementConfig_setValue"      , "_inputElementConfig_setChecked" ], ''InputElementConfig)   , (["_rawElementConfig_modifyAttributes"], ''RawElementConfig)@@ -409,6 +443,13 @@       setter t e = t { _textNodeConfig_setContents = Just e }   in lens getter setter +-- | This lens is technically illegal. The implementation of 'CommentNodeConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'CommentNodeConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'.+commentNodeConfig_setContents :: Reflex t => Lens (CommentNodeConfig t) (CommentNodeConfig t) (Event t Text) (Event t Text)+commentNodeConfig_setContents =+  let getter = fromMaybe never . _commentNodeConfig_setContents+      setter t e = t { _commentNodeConfig_setContents = Just e }+  in lens getter setter+ -- | This lens is technically illegal. The implementation of 'InputElementConfig' uses a 'Maybe' under the hood for efficiency reasons. However, always interacting with 'InputElementConfig' via lenses will always behave correctly, and if you pattern match on it, you should always treat 'Nothing' as 'never'. inputElementConfig_setValue :: Reflex t => Lens' (InputElementConfig er t m) (Event t Text) inputElementConfig_setValue =@@ -521,6 +562,7 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where   type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m   textNode = liftTextNode+  commentNode = liftCommentNode   element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do     s <- get     (el, (a, newS)) <- lift $ element elementTag cfg $ runStateT child s@@ -539,6 +581,7 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequesterT t request response m) where   type DomBuilderSpace (RequesterT t request response m) = DomBuilderSpace m   textNode = liftTextNode+  commentNode = liftCommentNode   element elementTag cfg (RequesterT child) = RequesterT $ do     r <- ask     old <- get@@ -559,6 +602,7 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m, Semigroup w) => DomBuilder t (EventWriterT t w m) where   type DomBuilderSpace (EventWriterT t w m) = DomBuilderSpace m   textNode = liftTextNode+  commentNode = liftCommentNode   element elementTag cfg (EventWriterT child) = EventWriterT $ do     old <- get     (el, (a, new)) <- lift $ element elementTag cfg $ runStateT child old@@ -574,9 +618,10 @@   placeRawElement = lift . placeRawElement   wrapRawElement e = lift . wrapRawElement e -instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive q) => DomBuilder t (QueryT t q m) where+instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive q, Eq q) => DomBuilder t (QueryT t q m) where   type DomBuilderSpace (QueryT t q m) = DomBuilderSpace m   textNode = liftTextNode+  commentNode = liftCommentNode   element elementTag cfg (QueryT child) = QueryT $ do     s <- get     (e, (a, newS)) <- lift $ element elementTag cfg $ runStateT child s@@ -645,6 +690,9 @@ liftTextNode :: (MonadTrans f, DomBuilder t m) => TextNodeConfig t -> f m (TextNode (DomBuilderSpace m) t) liftTextNode = lift . textNode +liftCommentNode :: (MonadTrans f, DomBuilder t m) => CommentNodeConfig t -> f m (CommentNode (DomBuilderSpace m) t)+liftCommentNode = lift . commentNode+ liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (DomBuilderSpace m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a) liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag cfg $ run child @@ -668,7 +716,9 @@   requestDomAction = lift . requestDomAction   requestDomAction_ = lift . requestDomAction_ +deriving instance DomRenderHook t m => DomRenderHook t (BehaviorWriterT t w m) deriving instance DomRenderHook t m => DomRenderHook t (EventWriterT t w m)+deriving instance DomRenderHook t m => DomRenderHook t (DynamicWriterT t w m) deriving instance DomRenderHook t m => DomRenderHook t (RequesterT t req rsp m) deriving instance DomRenderHook t m => DomRenderHook t (PostBuildT t m) deriving instance DomRenderHook t m => DomRenderHook t (QueryT t q m)

@@ -2,1550 +2,2631 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-#ifdef USE_TEMPLATE_HASKELL-{-# LANGUAGE TemplateHaskell #-}-#endif-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-#ifdef ghcjs_HOST_OS-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE JavaScriptFFI #-}-#endif-module Reflex.Dom.Builder.Immediate-       ( EventTriggerRef (..)-       , ImmediateDomBuilderEnv (..)-       , ImmediateDomBuilderT (..)-       , runImmediateDomBuilderT-       , askParent-       , askEvents-       , append-       , textNodeInternal-       , deleteBetweenExclusive-       , extractBetweenExclusive-       , deleteUpTo-       , extractUpTo-       , SupportsImmediateDomBuilder-       , collectUpTo-       , collectUpToGivenParent-       , EventFilterTriggerRef (..)-       , wrap-       , makeElement-       , GhcjsDomHandler (..)-       , GhcjsDomHandler1 (..)-       , GhcjsDomEvent (..)-       , GhcjsDomSpace-       , GhcjsEventFilter (..)-       , Pair1 (..)-       , Maybe1 (..)-       , GhcjsEventSpec (..)-       , HasDocument (..)-       , ghcjsEventSpec_filters-       , ghcjsEventSpec_handler-       , GhcjsEventHandler (..)-#ifndef USE_TEMPLATE_HASKELL-       , phantom2-#endif-       , drawChildUpdate-       , ChildReadyState (..)-       , ChildReadyStateInt (..)-       , mkHasFocus-       , insertBefore-       , EventType-       , defaultDomEventHandler-       , defaultDomWindowEventHandler-       , withIsEvent-       , showEventName-       , elementOnEventName-       , windowOnEventName-       , wrapDomEvent-       , subscribeDomEvent-       , wrapDomEventMaybe-       , wrapDomEventsMaybe-       , getKeyEvent-       , getMouseEventCoords-       , getTouchEvent-       , WindowConfig (..)-       , Window (..)-       , wrapWindow-       -- * Internal-       , traverseDMapWithKeyWithAdjust'-       , hoistTraverseWithKeyWithAdjust-       , traverseIntMapWithKeyWithAdjust'-       , hoistTraverseIntMapWithKeyWithAdjust-       ) where--import Foreign.JavaScript.TH-import Reflex.Adjustable.Class-import Reflex.Class as Reflex-import Reflex.Dom.Builder.Class-import Reflex.Dynamic-import Reflex.Host.Class-import qualified Reflex.Patch.DMap as PatchDMap-import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove-import Reflex.PerformEvent.Class-import Reflex.PostBuild.Class-import Reflex.TriggerEvent.Base hiding (askEvents)-import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)-import Reflex.TriggerEvent.Class--import Control.Concurrent-import Control.Lens hiding (element, ix)-import Control.Monad.Exception-import Control.Monad.Primitive-import Control.Monad.Reader-import Control.Monad.Ref-#ifndef USE_TEMPLATE_HASKELL-import Data.Functor.Contravariant (phantom)-#endif-import Data.Bitraversable-import Data.Default-import Data.Dependent.Map (DMap)-import qualified Data.Dependent.Map as DMap-import Data.Dependent.Sum-import Data.Functor.Compose-import Data.Functor.Constant-import Data.Functor.Misc-import Data.Functor.Product-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid hiding (Product)-import Data.Some (Some)-import qualified Data.Some as Some-import Data.Text (Text)-import qualified GHCJS.DOM as DOM-import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)-import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)-import qualified GHCJS.DOM.Element as Element-import qualified GHCJS.DOM.Event as Event-import qualified GHCJS.DOM.GlobalEventHandlers as Events-import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events-import GHCJS.DOM.EventM (EventM, event, on)-import qualified GHCJS.DOM.EventM as DOM-import qualified GHCJS.DOM.FileList as FileList-import qualified GHCJS.DOM.HTMLInputElement as Input-import qualified GHCJS.DOM.HTMLSelectElement as Select-import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea-import GHCJS.DOM.MouseEvent-import qualified GHCJS.DOM.Touch as Touch-import qualified GHCJS.DOM.TouchEvent as TouchEvent-import qualified GHCJS.DOM.TouchList as TouchList-import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)-import qualified GHCJS.DOM.Node as DOM (insertBefore_)-import GHCJS.DOM.Types-       (liftJSM, askJSM, runJSM, JSM, MonadJSM,-        FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,-        ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)-import qualified GHCJS.DOM.Types as DOM-import GHCJS.DOM.UIEvent-import GHCJS.DOM.KeyboardEvent as KeyboardEvent-import qualified GHCJS.DOM.Window as Window-import Language.Javascript.JSaddle (call, eval)-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap-import Data.FastMutableIntMap (PatchIntMap (..))-import qualified Data.FastMutableIntMap as FastMutableIntMap--import Reflex.Requester.Base-import Reflex.Requester.Class-import Foreign.JavaScript.Internal.Utils--#ifndef ghcjs_HOST_OS-import GHCJS.DOM.Types (MonadJSM (..))--instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where-    liftJSM' = ImmediateDomBuilderT . liftJSM'-#endif--data ImmediateDomBuilderEnv t-   = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document-                            , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node-                            , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered-                            , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it-                            }--newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }-  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException-#if MIN_VERSION_base(4,9,1)-           , MonadAsyncException-#endif-           )--instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where-  type PrimState (ImmediateDomBuilderT x m) = PrimState m-  primitive = lift . primitive--instance MonadTrans (ImmediateDomBuilderT t) where-  lift = ImmediateDomBuilderT . lift . lift . lift--instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where-  withRenderHook hook (ImmediateDomBuilderT a) = do-    e <- ImmediateDomBuilderT ask-    ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do-      (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp-      return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)-  requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity-  requestDomAction_ = ImmediateDomBuilderT . lift . requesting_--{-# INLINABLE runImmediateDomBuilderT #-}-runImmediateDomBuilderT-  :: ( MonadFix m-     , PerformEvent t m-     , MonadReflexCreateTrigger t m-     , MonadJSM m-     , MonadJSM (Performable m)-     , MonadRef m-     , Ref m ~ IORef-     )-  => ImmediateDomBuilderT t m a-  -> ImmediateDomBuilderEnv t-  -> Chan [DSum (EventTriggerRef t) TriggerInvocation]-  -> m a-runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =-  flip runTriggerEventT eventChan $ do-    rec (x, req) <- runRequesterT (runReaderT a env) rsp-        rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $-          traverseRequesterData (\r -> Identity <$> r) rm-    return x-  where-    runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do-        v <- synchronously x-        void . liftIO $ f v--instance Monad m => HasDocument (ImmediateDomBuilderT t m) where-  {-# INLINABLE askDocument #-}-  askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document--{-# INLINABLE askParent #-}-askParent :: Monad m => ImmediateDomBuilderT t m Node-askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent--{-# INLINABLE askEvents #-}-askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])-askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents--localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a-localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT--{-# INLINABLE append #-}-append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()-append n = do-  p <- askParent-  liftJSM $ appendChild_ p n-  return ()--{-# INLINABLE textNodeInternal #-}-textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text-textNodeInternal !t = do-  doc <- askDocument-  n <- liftJSM $ createTextNode doc t-  append $ toNode n-  return n---- | s and e must both be children of the same node and s must precede e;---   all nodes between s and e will be removed, but s and e will not be removed-deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()-deleteBetweenExclusive s e = liftJSM $ do-  df <- createDocumentFragment =<< getOwnerDocumentUnchecked s-  extractBetweenExclusive df s e -- In many places in ImmediateDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant---- | s and e must both be children of the same node and s must precede e; all---   nodes between s and e will be moved into the given DocumentFragment, but s---   and e will not be moved-extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()-extractBetweenExclusive df s e = liftJSM $ do-  f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text)-  void $ call f f (df, s, e)---- | s and e must both be children of the same node and s must precede e;---   s and all nodes between s and e will be removed, but e will not be removed-{-# INLINABLE deleteUpTo #-}-deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()-deleteUpTo s e = do-  df <- createDocumentFragment =<< getOwnerDocumentUnchecked s-  extractUpTo df s e -- In many places in ImmediateDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant--extractUpTo :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()-#ifdef ghcjs_HOST_OS---NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04)-foreign import javascript unsafe-  "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"-  extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()-extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e)-#else-extractUpTo df s e = liftJSM $ do-  f <- eval ("(function(df,s,e){ var x = s; var y; for(;;) { y = x['nextSibling']; df['appendChild'](x); if(e===y) { break; } x = y; } })" :: Text)-  void $ call f f (df, s, e)-#endif--type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, Adjustable t m, PrimMonad m)--{-# INLINABLE collectUpTo #-}-collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment-collectUpTo s e = do-  currentParent <- getParentNodeUnchecked e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment-  collectUpToGivenParent currentParent s e--{-# INLINABLE collectUpToGivenParent #-}-collectUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment-collectUpToGivenParent currentParent s e = do-  doc <- getOwnerDocumentUnchecked currentParent-  df <- createDocumentFragment doc-  extractUpTo df s e-  return df--newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))--{-# INLINABLE wrap #-}-wrap :: forall m er t. (Reflex t, MonadFix m, MonadJSM m, MonadReflexCreateTrigger t m) => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)-wrap e cfg = do-  events <- askEvents-  forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of-    Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv-    Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv-  eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do-    triggerRef <- liftIO $ newIORef Nothing-    _ <- elementOnEventName en e $ do --TODO: Something safer than this cast-      evt <- DOM.event-      (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt-      when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault-      case _eventFlags_propagation flags of-        Propagation_Continue -> return ()-        Propagation_Stop -> withIsEvent en DOM.stopPropagation-        Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation-      mv <- liftJSM k --TODO: Only do this when the event is subscribed-      liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]-    return $ en :=> EventFilterTriggerRef triggerRef-  es <- do-    let h :: GhcjsEventHandler er-        !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up-    ctx <- askJSM-    newFanEventWithTrigger $ \(WrapArg en) t ->-      case DMap.lookup en eventTriggerRefs of-        Just (EventFilterTriggerRef r) -> do-          writeIORef r $ Just t-          return $ do-            writeIORef r Nothing-        Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do-          evt <- DOM.event-          mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)-          case mv of-            Nothing -> return ()-            Just v -> liftIO $ do-              --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-              ref <- newIORef $ Just t-              writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])-  return $ Element-    { _element_events = es-    , _element_raw = e-    }--{-# INLINABLE makeElement #-}-makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)-makeElement elementTag cfg child = do-  doc <- askDocument-  e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of-    Nothing -> createElement doc elementTag-    Just ens -> createElementNS doc (Just ens) elementTag-  ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of-    Nothing -> lift $ setAttribute e n v-    Just ans -> lift $ setAttributeNS e (Just ans) n v-  result <- flip localEnv child $ \env -> env-    { _immediateDomBuilderEnv_parent = toNode e-    }-  append $ toNode e-  wrapped <- wrap e $ extractRawElementConfig cfg-  return ((wrapped, result), e)--newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }--newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> JSM (b x) }--newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }--data GhcjsDomSpace--instance DomSpace GhcjsDomSpace where-  type EventSpec GhcjsDomSpace = GhcjsEventSpec-  type RawDocument GhcjsDomSpace = DOM.Document-  type RawTextNode GhcjsDomSpace = DOM.Text-  type RawElement GhcjsDomSpace = DOM.Element-  type RawFile GhcjsDomSpace = DOM.File-  type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement-  type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement-  type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement-  addEventSpecFlags _ en f es = es-    { _ghcjsEventSpec_filters =-        let f' = Just . GhcjsEventFilter . \case-              Nothing -> \evt -> do-                mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)-                return (f mEventResult, return mEventResult)-              Just (GhcjsEventFilter oldFilter) -> \evt -> do-                (oldFlags, oldContinuation) <- oldFilter evt-                mEventResult <- oldContinuation-                let newFlags = oldFlags <> f mEventResult-                return (newFlags, return mEventResult)-        in DMap.alter f' en $ _ghcjsEventSpec_filters es-    }--newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> JSM (EventFlags, JSM (Maybe (er en))))--data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)--data Maybe1 f a = Nothing1 | Just1 (f a)--data GhcjsEventSpec er = GhcjsEventSpec-  { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)-  , _ghcjsEventSpec_handler :: GhcjsEventHandler er-  }--newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }--#ifndef USE_TEMPLATE_HASKELL-phantom2 :: (Functor f, Contravariant f) => f a -> f b-phantom2 = phantom-{-# INLINE phantom2 #-}--ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))-ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a-{-# INLINE ghcjsEventSpec_filters #-}-ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))-ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom2 (f b)-{-# INLINE ghcjsEventSpec_handler #-}-#endif--instance er ~ EventResult => Default (GhcjsEventSpec er) where-  def = GhcjsEventSpec-    { _ghcjsEventSpec_filters = mempty-    , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> do-        t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument-        let e = uncheckedCastTo DOM.Element t-        runReaderT (defaultDomEventHandler e en) evt-    }--instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where-  notReadyUntil e = do-    eOnce <- headE e-    env <- ImmediateDomBuilderT ask-    let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env-    liftIO $ modifyIORef' unreadyChildren succ-    let ready = do-          old <- liftIO $ readIORef unreadyChildren-          let new = pred old-          liftIO $ writeIORef unreadyChildren $! new-          when (new == 0) $ _immediateDomBuilderEnv_commitAction env-    requestDomAction_ $ ready <$ eOnce-  notReady = do-    env <- ImmediateDomBuilderT ask-    let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env-    liftIO $ modifyIORef' unreadyChildren succ--instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where-  type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace-  {-# INLINABLE textNode #-}-  textNode (TextNodeConfig initialContents mSetContents) = do-    n <- textNodeInternal initialContents-    mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents-    return $ TextNode n-  {-# INLINABLE element #-}-  element elementTag cfg child = fst <$> makeElement elementTag cfg child-  {-# INLINABLE inputElement #-}-  inputElement cfg = do-    ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()-    let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement-    Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue-    v0 <- Input.getValue domInputElement-    let getMyValue = Input.getValue domInputElement-    valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)-    valueChangedBySetValue <- case _inputElementConfig_setValue cfg of-      Nothing -> return never-      Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do-        Input.setValue domInputElement v'-        getMyValue -- We get the value after setting it in case the browser has mucked with it somehow-    v <- holdDyn v0 $ leftmost-      [ valueChangedBySetValue-      , valueChangedByUI-      ]-    Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg-    checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do-      Input.getChecked domInputElement-    checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of-      Nothing -> return never-      Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do-        oldChecked <- Input.getChecked domInputElement-        Input.setChecked domInputElement newChecked-        return $ if newChecked /= oldChecked-                    then Just newChecked-                    else Nothing-    c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost-      [ fmapMaybe id checkedChangedBySetChecked-      , checkedChangedByUI-      ]-    let initialFocus = False --TODO: Is this correct?-    hasFocus <- holdDyn initialFocus $ leftmost-      [ False <$ Reflex.select (_element_events e) (WrapArg Blur)-      , True <$ Reflex.select (_element_events e) (WrapArg Focus)-      ]-    files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do-      mfiles <- Input.getFiles domInputElement-      let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs-      maybe (return []) getMyFiles mfiles-    checked <- holdUniqDyn c-    return $ InputElement-      { _inputElement_value = v-      , _inputElement_checked = checked-      , _inputElement_checkedChange =  checkedChangedByUI-      , _inputElement_input = valueChangedByUI-      , _inputElement_hasFocus = hasFocus-      , _inputElement_element = e-      , _inputElement_raw = domInputElement-      , _inputElement_files = files-      }-  {-# INLINABLE textAreaElement #-}-  textAreaElement cfg = do --TODO-    ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()-    let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement-    TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue-    v0 <- TextArea.getValue domTextAreaElement-    let getMyValue = TextArea.getValue domTextAreaElement-    valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)-    valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of-      Nothing -> return never-      Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do-        TextArea.setValue domTextAreaElement v'-        getMyValue -- We get the value after setting it in case the browser has mucked with it somehow-    v <- holdDyn v0 $ leftmost-      [ valueChangedBySetValue-      , valueChangedByUI-      ]-    hasFocus <- mkHasFocus e-    return $ TextAreaElement-      { _textAreaElement_value = v-      , _textAreaElement_input = valueChangedByUI-      , _textAreaElement_hasFocus = hasFocus-      , _textAreaElement_element = e-      , _textAreaElement_raw = domTextAreaElement-      }-  {-# INLINABLE selectElement #-}-  selectElement cfg child = do-    ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child-    let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement-    Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue-    v0 <- Select.getValue domSelectElement-    let getMyValue = Select.getValue domSelectElement-    valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)-    valueChangedBySetValue <- case _selectElementConfig_setValue cfg of-      Nothing -> return never-      Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do-        Select.setValue domSelectElement v'-        getMyValue -- We get the value after setting it in case the browser has mucked with it somehow-    v <- holdDyn v0 $ leftmost-      [ valueChangedBySetValue-      , valueChangedByUI-      ]-    hasFocus <- mkHasFocus e-    let wrapped = SelectElement-          { _selectElement_value = v-          , _selectElement_change = valueChangedByUI-          , _selectElement_hasFocus = hasFocus-          , _selectElement_element = e-          , _selectElement_raw = domSelectElement-          }-    return (wrapped, result)-  placeRawElement = append . toNode-  wrapRawElement = wrap--data FragmentState-  = FragmentState_Unmounted-  | FragmentState_Mounted (DOM.Text, DOM.Text)--data ImmediateDomFragment = ImmediateDomFragment-  { _immediateDomFragment_document :: DOM.DocumentFragment-  , _immediateDomFragment_state :: IORef FragmentState-  }--extractFragment :: MonadJSM m => ImmediateDomFragment -> m ()-extractFragment fragment = do-  state <- liftIO $ readIORef $ _immediateDomFragment_state fragment-  case state of-    FragmentState_Unmounted -> return ()-    FragmentState_Mounted (before, after) -> do-      extractBetweenExclusive (_immediateDomFragment_document fragment) before after-      liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted--instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where-  type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment-  buildDomFragment w = do-    df <- createDocumentFragment =<< askDocument-    result <- flip localEnv w $ \env -> env-      { _immediateDomBuilderEnv_parent = toNode df-      }-    state <- liftIO $ newIORef FragmentState_Unmounted-    return (ImmediateDomFragment df state, result)-  mountDomFragment fragment setFragment = do-    parent <- askParent-    extractFragment fragment-    before <- textNodeInternal ("" :: Text)-    appendChild_ parent $ _immediateDomFragment_document fragment-    after <- textNodeInternal ("" :: Text)-    xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment-    requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do-      extractFragment previousFragment-      extractFragment childFragment-      insertBefore (_immediateDomFragment_document childFragment) after-      liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)-    liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)--instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where-  {-# INLINABLE runWithReplace #-}-  runWithReplace a0 a' = do-    initialEnv <- ImmediateDomBuilderT ask-    before <- textNodeInternal ("" :: Text)-    let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv-    haveEverBeenReady <- liftIO $ newIORef False-    currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM-    let myCommitAction = do-          liftIO (readIORef haveEverBeenReady) >>= \case-            True -> return ()-            False -> do-              liftIO $ writeIORef haveEverBeenReady True-              old <- liftIO $ readIORef parentUnreadyChildren-              let new = pred old-              liftIO $ writeIORef parentUnreadyChildren $! new-              when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv-    -- We draw 'after' in this roundabout way to avoid using MonadFix-    doc <- askDocument-    after <- createTextNode doc ("" :: Text)-    let drawInitialChild = do-          unreadyChildren <- liftIO $ newIORef 0-          let f = do-                result <- a0-                append $ toNode after-                return result-          result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv-            { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren-            , _immediateDomBuilderEnv_commitAction = myCommitAction-            }-          liftIO $ readIORef unreadyChildren >>= \case-            0 -> writeIORef haveEverBeenReady True-            _ -> modifyIORef' parentUnreadyChildren succ-          return result-    a'' <- numberOccurrences a'-    (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do-      df <- createDocumentFragment doc-      unreadyChildren <- liftIO $ newIORef 0-      let commitAction = do-            c <- liftIO $ readIORef currentCohort-            when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this-              deleteBetweenExclusive before after-              insertBefore df after-              liftIO $ writeIORef currentCohort cohortId-              myCommitAction-      result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv-        { _immediateDomBuilderEnv_parent = toNode df-        , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren-        , _immediateDomBuilderEnv_commitAction = commitAction-        }-      uc <- liftIO $ readIORef unreadyChildren-      let commitActionToRunNow = if uc == 0-            then Just commitAction-            else Nothing -- A child will run it when unreadyChildren is decremented to 0-      return (commitActionToRunNow, result)-    requestDomAction_ $ fmapMaybe fst child'-    return (result0, snd <$> child')-  {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}-  traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'-  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}-  traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'-  {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}-  traverseDMapWithKeyWithAdjustWithMove = do-    let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do-          let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)-              new k = PatchDMapWithMove.nodeInfoMapFromM $ \case-                PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do-                  readIORef sRef >>= \case-                    ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete-                    ChildReadyState_Unready _ -> do-                      writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k-                      return $ PatchDMapWithMove.From_Insert $ Constant sRef-                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 k))) (ComposeMaybe k) a -> IO (Constant () a)-              deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do-                writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> 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-          return $ applyAlways p' old-    hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do-      let p = unPatchDMapWithMove p_-      phsBefore <- liftIO $ readIORef placeholders-      lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef-      let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)-          collectIfMoved k e = do-            let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before-                nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore-            case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of-              False -> do-                mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder-                return $ Constant Nothing-              True -> do-                Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder-      collected <- DMap.traverseWithKey collectIfMoved p-      let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this-      let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)-          placeFragment k e = do-            let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter-            case PatchDMapWithMove._nodeInfo_from e of-              PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do-                df `insertBefore` nextPlaceholder-              PatchDMapWithMove.From_Delete -> do-                return ()-              PatchDMapWithMove.From_Move fromKey -> do-                Just (Constant mdf) <- return $ DMap.lookup fromKey collected-                mapM_ (`insertBefore` nextPlaceholder) mdf-            return $ Constant ()-      mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time-      liftIO $ writeIORef placeholders $! phsAfter--{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}-traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> ImmediateDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))-traverseDMapWithKeyWithAdjust' = do-  let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do-        let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)-            new k (ComposeMaybe m) = ComposeMaybe <$> case m of-              Nothing -> return Nothing-              Just (Compose (_, _, sRef, _)) -> do-                readIORef sRef >>= \case-                  ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready-                  ChildReadyState_Unready _ -> do-                    writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k-                    return $ Just $ Constant sRef-            delete _ (Constant sRef) = do-              writeIORef sRef $ ChildReadyState_Unready Nothing-              return $ Constant ()-        p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p-        _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old-        return $ applyAlways p' old-  hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do-    phs <- liftIO $ readIORef placeholders-    forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do-      lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef-      let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs-      forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder-      forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder-    liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs--{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}-traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> ImmediateDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> ImmediateDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))-traverseIntMapWithKeyWithAdjust' = do-  let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do-        let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))-            new k m = case m of-              Nothing -> return Nothing-              Just (_, _, sRef, _) -> do-                readIORef sRef >>= \case-                  ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready-                  ChildReadyStateInt_Unready _ -> do-                    writeIORef sRef $ ChildReadyStateInt_Unready $ Just k-                    return $ Just sRef-            delete _ sRef = do-              writeIORef sRef $ ChildReadyStateInt_Unready Nothing-              return ()-        p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner-        _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old-        return $ applyAlways p' old-  hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do-    phs <- liftIO $ readIORef placeholders-    forM_ (IntMap.toList p) $ \(k, mv) -> do-      lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef-      let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs-      forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder-      forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder-    liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs--#if MIN_VERSION_base(4,9,0)-data ChildReadyState k-#else-data ChildReadyState (k :: * -> *)-#endif-   = ChildReadyState_Ready-   | ChildReadyState_Unready !(Maybe (Some k))-   deriving (Show, Read, Eq, Ord)--data ChildReadyStateInt-   = ChildReadyStateInt_Ready-   | ChildReadyStateInt_Unready !(Maybe Int)-   deriving (Show, Read, Eq, Ord)--{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}-hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.-  ( Adjustable t m-  , MonadIO m-  , MonadJSM m-  , MonadFix m-  , PrimMonad m-  , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))-  , Functor p-  )-  => (   (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))-      -> IntMap v-      -> Event t (p v)-      -> RequesterT t JSM Identity (TriggerEventT t m) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))-     ) -- ^ The base monad's traversal-  -> (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state-  -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM-  -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')-  -> IntMap v-  -> Event t (p v)-  -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))-hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do-  initialEnv <- ImmediateDomBuilderT ask-  let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv-  pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty-  haveEverBeenReady <- liftIO $ newIORef False-  placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"-  lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"-  let applyDomUpdate p = do-        applyDomUpdate_ placeholders lastPlaceholderRef p-        markSelfReady-        liftIO $ writeIORef pendingChange $! mempty-      markSelfReady = do-        liftIO (readIORef haveEverBeenReady) >>= \case-          True -> return ()-          False -> do-            liftIO $ writeIORef haveEverBeenReady True-            old <- liftIO $ readIORef parentUnreadyChildren-            let new = pred old-            liftIO $ writeIORef parentUnreadyChildren $! new-            when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv-      markChildReady :: IORef ChildReadyStateInt -> JSM ()-      markChildReady childReadyState = do-        liftIO (readIORef childReadyState) >>= \case-          ChildReadyStateInt_Ready -> return ()-          ChildReadyStateInt_Unready countedAt -> do-            liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready-            case countedAt of-              Nothing -> return ()-              Just 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 $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null-                  let newUnready = IntMap.delete k oldUnready-                  liftIO $ writeIORef pendingChange (newUnready, p)-                  when (IntMap.null newUnready) $ do-                    applyDomUpdate p-  (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'-  let processChild k (_, _, sRef, _) = do-        readIORef sRef >>= \case-          ChildReadyStateInt_Ready -> return Nothing-          ChildReadyStateInt_Unready _ -> do-            writeIORef sRef $ ChildReadyStateInt_Unready $ Just k-            return $ Just sRef-  initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0-  liftIO $ if IntMap.null initialUnready-    then writeIORef haveEverBeenReady True-    else do-      modifyIORef' parentUnreadyChildren succ-      writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time-  let result0 = IntMap.map (\(_, _, _, v) -> v) children0-      placeholders0 = fmap (\(_, ph, _, _) -> ph) children0-      result' = ffor children' $ fmap $ \(_, _, _, r) -> r-  liftIO $ writeIORef placeholders $! placeholders0-  _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0-  liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)-  requestDomAction_ $ ffor children' $ \p -> do-    (oldUnready, oldP) <- liftIO $ readIORef pendingChange-    newUnready <- liftIO $ updateChildUnreadiness p oldUnready-    let !newP = p <> oldP-    liftIO $ writeIORef pendingChange (newUnready, newP)-    when (IntMap.null newUnready) $ do-      applyDomUpdate newP-  return (result0, result')--{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}-hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.-  ( Adjustable t m-  , MonadHold t m-  , DMap.GCompare k-  , MonadIO m-  , MonadJSM m-  , PrimMonad m-  , MonadFix m-  , Patch (p k v)-  , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)-  , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))-  , Patch (p k (Constant Int))-  )-  => (forall vv vv'.-         (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))-      -> DMap k vv-      -> Event t (p k vv)-      -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))-     ) -- ^ The base monad's traversal-  -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type-  -> (p k (Compose ((,,,) 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-  -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM-  -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))-  -> DMap k v-  -> Event t (p k v)-  -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))-hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do-  initialEnv <- ImmediateDomBuilderT ask-  let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv-  pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty-  haveEverBeenReady <- liftIO $ newIORef False-  placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"-  lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"-  let applyDomUpdate p = do-        applyDomUpdate_ placeholders lastPlaceholderRef p-        markSelfReady-        liftIO $ writeIORef pendingChange $! mempty-      markSelfReady = do-        liftIO (readIORef haveEverBeenReady) >>= \case-          True -> return ()-          False -> do-            liftIO $ writeIORef haveEverBeenReady True-            old <- liftIO $ readIORef parentUnreadyChildren-            let new = pred old-            liftIO $ writeIORef parentUnreadyChildren $! new-            when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv-      markChildReady :: IORef (ChildReadyState k) -> JSM ()-      markChildReady childReadyState = do-        liftIO (readIORef childReadyState) >>= \case-          ChildReadyState_Ready -> return ()-          ChildReadyState_Unready countedAt -> do-            liftIO $ writeIORef childReadyState ChildReadyState_Ready-            case countedAt of-              Nothing -> return ()-              Just (Some.This 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-                  liftIO $ writeIORef pendingChange (newUnready, p)-                  when (DMap.null newUnready) $ do-                    applyDomUpdate p-  (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'-  let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do-        readIORef sRef >>= \case-          ChildReadyState_Ready -> return Nothing-          ChildReadyState_Unready _ -> do-            writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k-            return $ Just $ Constant sRef-  initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0-  liftIO $ if DMap.null initialUnready-    then writeIORef haveEverBeenReady True-    else do-      modifyIORef' parentUnreadyChildren succ-      writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time-  let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0-      placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0-      result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r-  liftIO $ writeIORef placeholders $! placeholders0-  _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0-  liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)-  requestDomAction_ $ ffor children' $ \p -> do-    (oldUnready, oldP) <- liftIO $ readIORef pendingChange-    newUnready <- liftIO $ updateChildUnreadiness p oldUnready-    let !newP = p <> oldP-    liftIO $ writeIORef pendingChange (newUnready, newP)-    when (DMap.null newUnready) $ do-      applyDomUpdate newP-  return (result0, result')--{-# INLINABLE drawChildUpdate #-}-drawChildUpdate :: (MonadIO m, MonadJSM m)-  => ImmediateDomBuilderEnv t-  -> (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-  -> ImmediateDomBuilderT t m (v' a)-  -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)-drawChildUpdate initialEnv markReady child = do-  childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing-  unreadyChildren <- liftIO $ newIORef 0-  df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv-  (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv-    { _immediateDomBuilderEnv_parent = toNode df-    , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren-    , _immediateDomBuilderEnv_commitAction = markReady childReadyState-    }-  u <- liftIO $ readIORef unreadyChildren-  when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready-  return $ Compose (df, placeholder, childReadyState, result)--{-# INLINABLE drawChildUpdateInt #-}-drawChildUpdateInt :: (MonadIO m, MonadJSM m)-  => ImmediateDomBuilderEnv t-  -> (IORef ChildReadyStateInt -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready-  -> ImmediateDomBuilderT t m v'-  -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')-drawChildUpdateInt initialEnv markReady child = do-  childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing-  unreadyChildren <- liftIO $ newIORef 0-  df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv-  (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv-    { _immediateDomBuilderEnv_parent = toNode df-    , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren-    , _immediateDomBuilderEnv_commitAction = markReady childReadyState-    }-  u <- liftIO $ readIORef unreadyChildren-  when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready-  return (df, placeholder, childReadyState, result)--mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)-mkHasFocus e = do-  let initialFocus = False --TODO: Actually get the initial focus of the element-  holdDyn initialFocus $ leftmost-    [ False <$ Reflex.select (_element_events e) (WrapArg Blur)-    , True <$ Reflex.select (_element_events e) (WrapArg Focus)-    ]--insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()-insertBefore new existing = do-  p <- getParentNodeUnchecked existing-  DOM.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly--instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where-  type Performable (ImmediateDomBuilderT t m) = Performable m-  {-# INLINABLE performEvent_ #-}-  performEvent_ e = lift $ performEvent_ e-  {-# INLINABLE performEvent #-}-  performEvent e = lift $ performEvent e--instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where-  {-# INLINABLE getPostBuild #-}-  getPostBuild = lift getPostBuild--instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where-  {-# INLINABLE newEventWithTrigger #-}-  newEventWithTrigger = lift . newEventWithTrigger-  {-# INLINABLE newFanEventWithTrigger #-}-  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f--instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where-  {-# INLINABLE newTriggerEvent #-}-  newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent-  {-# INLINABLE newTriggerEventWithOnComplete #-}-  newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete-  {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}-  newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f--instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where-  type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m-  askJSContext = lift askJSContext--instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where-  type Ref (ImmediateDomBuilderT t m) = Ref m-  {-# INLINABLE newRef #-}-  newRef = lift . newRef-  {-# INLINABLE readRef #-}-  readRef = lift . readRef-  {-# INLINABLE writeRef #-}-  writeRef r = lift . writeRef r--instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where-  {-# INLINABLE atomicModifyRef #-}-  atomicModifyRef r = lift . atomicModifyRef r--instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where-  type JSX (ImmediateDomBuilderT t m) = JSX m-  liftJS = lift . liftJS--type family EventType en where-  EventType 'AbortTag = UIEvent-  EventType 'BlurTag = FocusEvent-  EventType 'ChangeTag = DOM.Event-  EventType 'ClickTag = MouseEvent-  EventType 'ContextmenuTag = MouseEvent-  EventType 'DblclickTag = MouseEvent-  EventType 'DragTag = MouseEvent-  EventType 'DragendTag = MouseEvent-  EventType 'DragenterTag = MouseEvent-  EventType 'DragleaveTag = MouseEvent-  EventType 'DragoverTag = MouseEvent-  EventType 'DragstartTag = MouseEvent-  EventType 'DropTag = MouseEvent-  EventType 'ErrorTag = UIEvent-  EventType 'FocusTag = FocusEvent-  EventType 'InputTag = DOM.Event-  EventType 'InvalidTag = DOM.Event-  EventType 'KeydownTag = KeyboardEvent-  EventType 'KeypressTag = KeyboardEvent-  EventType 'KeyupTag = KeyboardEvent-  EventType 'LoadTag = UIEvent-  EventType 'MousedownTag = MouseEvent-  EventType 'MouseenterTag = MouseEvent-  EventType 'MouseleaveTag = MouseEvent-  EventType 'MousemoveTag = MouseEvent-  EventType 'MouseoutTag = MouseEvent-  EventType 'MouseoverTag = MouseEvent-  EventType 'MouseupTag = MouseEvent-  EventType 'MousewheelTag = MouseEvent-  EventType 'ScrollTag = UIEvent-  EventType 'SelectTag = UIEvent-  EventType 'SubmitTag = DOM.Event-  EventType 'WheelTag = WheelEvent-  EventType 'BeforecutTag = ClipboardEvent-  EventType 'CutTag = ClipboardEvent-  EventType 'BeforecopyTag = ClipboardEvent-  EventType 'CopyTag = ClipboardEvent-  EventType 'BeforepasteTag = ClipboardEvent-  EventType 'PasteTag = ClipboardEvent-  EventType 'ResetTag = DOM.Event-  EventType 'SearchTag = DOM.Event-  EventType 'SelectstartTag = DOM.Event-  EventType 'TouchstartTag = TouchEvent-  EventType 'TouchmoveTag = TouchEvent-  EventType 'TouchendTag = TouchEvent-  EventType 'TouchcancelTag = TouchEvent--{-# INLINABLE defaultDomEventHandler #-}-defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))-defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of-  Click -> return ()-  Dblclick -> getMouseEventCoords-  Keypress -> getKeyEvent-  Scroll -> fromIntegral <$> getScrollTop e-  Keydown -> getKeyEvent-  Keyup -> getKeyEvent-  Mousemove -> getMouseEventCoords-  Mouseup -> getMouseEventCoords-  Mousedown -> getMouseEventCoords-  Mouseenter -> return ()-  Mouseleave -> return ()-  Focus -> return ()-  Blur -> return ()-  Change -> return ()-  Drag -> return ()-  Dragend -> return ()-  Dragenter -> return ()-  Dragleave -> return ()-  Dragover -> return ()-  Dragstart -> return ()-  Drop -> return ()-  Abort -> return ()-  Contextmenu -> return ()-  Error -> return ()-  Input -> return ()-  Invalid -> return ()-  Load -> return ()-  Mouseout -> return ()-  Mouseover -> return ()-  Select -> return ()-  Submit -> return ()-  Beforecut -> return ()-  Cut -> return ()-  Beforecopy -> return ()-  Copy -> return ()-  Beforepaste -> return ()-  Paste -> return ()-  Reset -> return ()-  Search -> return ()-  Selectstart -> return ()-  Touchstart -> getTouchEvent-  Touchmove -> getTouchEvent-  Touchend -> getTouchEvent-  Touchcancel -> getTouchEvent-  Mousewheel -> return ()-  Wheel -> return ()--{-# INLINABLE defaultDomWindowEventHandler #-}-defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))-defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of-  Click -> return ()-  Dblclick -> getMouseEventCoords-  Keypress -> getKeyEvent-  Scroll -> Window.getScrollY w-  Keydown -> getKeyEvent-  Keyup -> getKeyEvent-  Mousemove -> getMouseEventCoords-  Mouseup -> getMouseEventCoords-  Mousedown -> getMouseEventCoords-  Mouseenter -> return ()-  Mouseleave -> return ()-  Focus -> return ()-  Blur -> return ()-  Change -> return ()-  Drag -> return ()-  Dragend -> return ()-  Dragenter -> return ()-  Dragleave -> return ()-  Dragover -> return ()-  Dragstart -> return ()-  Drop -> return ()-  Abort -> return ()-  Contextmenu -> return ()-  Error -> return ()-  Input -> return ()-  Invalid -> return ()-  Load -> return ()-  Mouseout -> return ()-  Mouseover -> return ()-  Select -> return ()-  Submit -> return ()-  Beforecut -> return ()-  Cut -> return ()-  Beforecopy -> return ()-  Copy -> return ()-  Beforepaste -> return ()-  Paste -> return ()-  Reset -> return ()-  Search -> return ()-  Selectstart -> return ()-  Touchstart -> getTouchEvent-  Touchmove -> getTouchEvent-  Touchend -> getTouchEvent-  Touchcancel -> getTouchEvent-  Mousewheel -> return ()-  Wheel -> return ()--{-# INLINABLE withIsEvent #-}-withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r-withIsEvent en r = case en of-  Click -> r-  Dblclick -> r-  Keypress -> r-  Scroll -> r-  Keydown -> r-  Keyup -> r-  Mousemove -> r-  Mouseup -> r-  Mousedown -> r-  Mouseenter -> r-  Mouseleave -> r-  Focus -> r-  Blur -> r-  Change -> r-  Drag -> r-  Dragend -> r-  Dragenter -> r-  Dragleave -> r-  Dragover -> r-  Dragstart -> r-  Drop -> r-  Abort -> r-  Contextmenu -> r-  Error -> r-  Input -> r-  Invalid -> r-  Load -> r-  Mouseout -> r-  Mouseover -> r-  Select -> r-  Submit -> r-  Beforecut -> r-  Cut -> r-  Beforecopy -> r-  Copy -> r-  Beforepaste -> r-  Paste -> r-  Reset -> r-  Search -> r-  Selectstart -> r-  Touchstart -> r-  Touchmove -> r-  Touchend -> r-  Touchcancel -> r-  Mousewheel -> r-  Wheel -> r--showEventName :: EventName en -> String-showEventName en = case en of-  Abort -> "Abort"-  Blur -> "Blur"-  Change -> "Change"-  Click -> "Click"-  Contextmenu -> "Contextmenu"-  Dblclick -> "Dblclick"-  Drag -> "Drag"-  Dragend -> "Dragend"-  Dragenter -> "Dragenter"-  Dragleave -> "Dragleave"-  Dragover -> "Dragover"-  Dragstart -> "Dragstart"-  Drop -> "Drop"-  Error -> "Error"-  Focus -> "Focus"-  Input -> "Input"-  Invalid -> "Invalid"-  Keydown -> "Keydown"-  Keypress -> "Keypress"-  Keyup -> "Keyup"-  Load -> "Load"-  Mousedown -> "Mousedown"-  Mouseenter -> "Mouseenter"-  Mouseleave -> "Mouseleave"-  Mousemove -> "Mousemove"-  Mouseout -> "Mouseout"-  Mouseover -> "Mouseover"-  Mouseup -> "Mouseup"-  Mousewheel -> "Mousewheel"-  Scroll -> "Scroll"-  Select -> "Select"-  Submit -> "Submit"-  Wheel -> "Wheel"-  Beforecut -> "Beforecut"-  Cut -> "Cut"-  Beforecopy -> "Beforecopy"-  Copy -> "Copy"-  Beforepaste -> "Beforepaste"-  Paste -> "Paste"-  Reset -> "Reset"-  Search -> "Search"-  Selectstart -> "Selectstart"-  Touchstart -> "Touchstart"-  Touchmove -> "Touchmove"-  Touchend -> "Touchend"-  Touchcancel -> "Touchcancel"----TODO: Get rid of this hack--- ElementEventTarget is here to allow us to treat SVG and HTML elements as the same thing; without it, we'll break any existing SVG code.-newtype ElementEventTarget = ElementEventTarget DOM.Element deriving (DOM.IsGObject, DOM.ToJSVal, DOM.IsSlotable, DOM.IsParentNode, DOM.IsNonDocumentTypeChildNode, DOM.IsChildNode, DOM.IsAnimatable, IsNode, IsElement)-instance DOM.FromJSVal ElementEventTarget where-  fromJSVal = fmap (fmap ElementEventTarget) . DOM.fromJSVal-instance DOM.IsEventTarget ElementEventTarget-instance DOM.IsGlobalEventHandlers ElementEventTarget-instance DOM.IsDocumentAndElementEventHandlers ElementEventTarget--{-# INLINABLE elementOnEventName #-}-elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())-elementOnEventName en e_ = let e = ElementEventTarget (DOM.toElement e_) in case en of-  Abort -> on e Events.abort-  Blur -> on e Events.blur-  Change -> on e Events.change-  Click -> on e Events.click-  Contextmenu -> on e Events.contextMenu-  Dblclick -> on e Events.dblClick-  Drag -> on e Events.drag-  Dragend -> on e Events.dragEnd-  Dragenter -> on e Events.dragEnter-  Dragleave -> on e Events.dragLeave-  Dragover -> on e Events.dragOver-  Dragstart -> on e Events.dragStart-  Drop -> on e Events.drop-  Error -> on e Events.error-  Focus -> on e Events.focus-  Input -> on e Events.input-  Invalid -> on e Events.invalid-  Keydown -> on e Events.keyDown-  Keypress -> on e Events.keyPress-  Keyup -> on e Events.keyUp-  Load -> on e Events.load-  Mousedown -> on e Events.mouseDown-  Mouseenter -> on e Events.mouseEnter-  Mouseleave -> on e Events.mouseLeave-  Mousemove -> on e Events.mouseMove-  Mouseout -> on e Events.mouseOut-  Mouseover -> on e Events.mouseOver-  Mouseup -> on e Events.mouseUp-  Mousewheel -> on e Events.mouseWheel-  Scroll -> on e Events.scroll-  Select -> on e Events.select-  Submit -> on e Events.submit-  Wheel -> on e Events.wheel-  Beforecut -> on e Events.beforeCut-  Cut -> on e Events.cut-  Beforecopy -> on e Events.beforeCopy-  Copy -> on e Events.copy-  Beforepaste -> on e Events.beforePaste-  Paste -> on e Events.paste-  Reset -> on e Events.reset-  Search -> on e Events.search-  Selectstart -> on e Element.selectStart-  Touchstart -> on e Events.touchStart-  Touchmove -> on e Events.touchMove-  Touchend -> on e Events.touchEnd-  Touchcancel -> on e Events.touchCancel--{-# INLINABLE windowOnEventName #-}-windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> JSM (JSM ())-windowOnEventName en e = case en of-  Abort -> on e Events.abort-  Blur -> on e Events.blur-  Change -> on e Events.change-  Click -> on e Events.click-  Contextmenu -> on e Events.contextMenu-  Dblclick -> on e Events.dblClick-  Drag -> on e Events.drag-  Dragend -> on e Events.dragEnd-  Dragenter -> on e Events.dragEnter-  Dragleave -> on e Events.dragLeave-  Dragover -> on e Events.dragOver-  Dragstart -> on e Events.dragStart-  Drop -> on e Events.drop-  Error -> on e Events.error-  Focus -> on e Events.focus-  Input -> on e Events.input-  Invalid -> on e Events.invalid-  Keydown -> on e Events.keyDown-  Keypress -> on e Events.keyPress-  Keyup -> on e Events.keyUp-  Load -> on e Events.load-  Mousedown -> on e Events.mouseDown-  Mouseenter -> on e Events.mouseEnter-  Mouseleave -> on e Events.mouseLeave-  Mousemove -> on e Events.mouseMove-  Mouseout -> on e Events.mouseOut-  Mouseover -> on e Events.mouseOver-  Mouseup -> on e Events.mouseUp-  Mousewheel -> on e Events.mouseWheel-  Scroll -> on e Events.scroll-  Select -> on e Events.select-  Submit -> on e Events.submit-  Wheel -> on e Events.wheel-  Beforecut -> const $ return $ return () --TODO-  Cut -> const $ return $ return () --TODO-  Beforecopy -> const $ return $ return () --TODO-  Copy -> const $ return $ return () --TODO-  Beforepaste -> const $ return $ return () --TODO-  Paste -> const $ return $ return () --TODO-  Reset -> on e Events.reset-  Search -> on e Events.search-  Selectstart -> const $ return $ return () --TODO-  Touchstart -> on e Events.touchStart-  Touchmove -> on e Events.touchMove-  Touchend -> on e Events.touchEnd-  Touchcancel -> on e Events.touchCancel--{-# INLINABLE wrapDomEvent #-}-wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)-wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue--{-# INLINABLE subscribeDomEvent #-}-subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))-                  -> EventM e event (Maybe a)-                  -> Chan [DSum (EventTriggerRef t) TriggerInvocation]-                  -> EventTrigger t a-                  -> JSM (JSM ())-subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do-  mv <- getValue-  forM_ mv $ \v -> liftIO $ do-    --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-    etr <- newIORef $ Just et-    writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]--{-# INLINABLE wrapDomEventMaybe #-}-wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)-                  => e-                  -> (e -> EventM e event () -> JSM (JSM ()))-                  -> EventM e event (Maybe a)-                  -> m (Event t a)-wrapDomEventMaybe el elementOnevent getValue = do-  ctx <- askJSM-  newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do-    mv <- getValue-    forM_ mv $ \v -> liftIO $ trigger v $ return ())--{-# INLINABLE wrapDomEventsMaybe #-}-wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)-                   => e-                   -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))-                   -> (forall en. EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ()))-                   -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))-wrapDomEventsMaybe target handlers onEventName = do-  ctx <- askJSM-  eventChan <- askEvents-  e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en-    (((`runJSM` ctx) <$>) . (`runJSM` ctx) . subscribeDomEvent (onEventName en target) (handlers en) eventChan)-  return $! e--{-# INLINABLE getKeyEvent #-}-getKeyEvent :: EventM e KeyboardEvent Word-getKeyEvent = do-  e <- event-  which <- KeyboardEvent.getWhich e-  if which /= 0 then return which else do-    charCode <- getCharCode e-    if charCode /= 0 then return charCode else-      getKeyCode e--{-# INLINABLE getMouseEventCoords #-}-getMouseEventCoords :: EventM e MouseEvent (Int, Int)-getMouseEventCoords = do-  e <- event-  bisequence (getClientX e, getClientY e)--{-# INLINABLE getTouchEvent #-}-getTouchEvent :: EventM e TouchEvent TouchEventResult-getTouchEvent = do-  let touchResults ts = do-          n <- TouchList.getLength ts-          forM (takeWhile (< n) [0..]) $ \ix -> do-            t <- TouchList.item ts ix-            identifier <- Touch.getIdentifier t-            screenX <- Touch.getScreenX t-            screenY <- Touch.getScreenY t-            clientX <- Touch.getClientX t-            clientY <- Touch.getClientY t-            pageX <- Touch.getPageX t-            pageY <- Touch.getPageY t-            return TouchResult-              { _touchResult_identifier = identifier-              , _touchResult_screenX = screenX-              , _touchResult_screenY = screenY-              , _touchResult_clientX = clientX-              , _touchResult_clientY = clientY-              , _touchResult_pageX = pageX-              , _touchResult_pageY = pageY-              }-  e <- event-  altKey <- TouchEvent.getAltKey e-  ctrlKey <- TouchEvent.getCtrlKey e-  shiftKey <- TouchEvent.getShiftKey e-  metaKey <- TouchEvent.getMetaKey e-  changedTouches <- touchResults =<< TouchEvent.getChangedTouches e-  targetTouches <- touchResults =<< TouchEvent.getTargetTouches e-  touches <- touchResults =<< TouchEvent.getTouches e-  return $ TouchEventResult-    { _touchEventResult_altKey = altKey-    , _touchEventResult_changedTouches = changedTouches-    , _touchEventResult_ctrlKey = ctrlKey-    , _touchEventResult_metaKey = metaKey-    , _touchEventResult_shiftKey = shiftKey-    , _touchEventResult_targetTouches = targetTouches-    , _touchEventResult_touches = touches-    }--instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where-  {-# INLINABLE sample #-}-  sample = lift . sample--instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where-  {-# INLINABLE hold #-}-  hold v0 v' = lift $ hold v0 v'-  {-# INLINABLE holdDyn #-}-  holdDyn v0 v' = lift $ holdDyn v0 v'-  {-# INLINABLE holdIncremental #-}-  holdIncremental v0 v' = lift $ holdIncremental v0 v'-  {-# INLINABLE buildDynamic #-}-  buildDynamic a0 = lift . buildDynamic a0-  {-# INLINABLE headE #-}-  headE = lift . headE--data WindowConfig t = WindowConfig -- No config options yet--instance Default (WindowConfig t) where-  def = WindowConfig--data Window t = Window-  { _window_events :: EventSelector t (WrapArg EventResult EventName)-  , _window_raw :: DOM.Window-  }--wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+#ifdef USE_TEMPLATE_HASKELL+{-# LANGUAGE TemplateHaskell #-}+#endif+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+#ifdef ghcjs_HOST_OS+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+#endif+-- | This is a builder to be used on the client side. It can be run in two modes:+--+--  1. in "hydration mode", reusing DOM nodes already in the page (as produced+--  by 'Reflex.Dom.Builder.Static.renderStatic')+--  2. in "immediate mode", creating and appending DOM nodes as required+--+-- In "hydration mode", the preexisting DOM __must contain__ what the builder+-- will expect at switchover time (the time at which parity with the static+-- renderer is reached, and the time after which the page is "live").+--+-- For example, displaying the current time as text should be done inside+-- 'Reflex.Dom.Prerender.prerender' to ensure that we don't attempt to hydrate the incorrect text.+-- The server will prerender a text node with time A, and the client will expect+-- a text node with time B. Barring a miracle, time A and time B will not match,+-- and hydration will fail.+module Reflex.Dom.Builder.Immediate+  ( HydrationDomBuilderT (..)+  , HydrationDomBuilderEnv (..)+  , HydrationMode (..)+  , HydrationRunnerT (..)+  , runHydrationRunnerT+  , ImmediateDomBuilderT+  , runHydrationDomBuilderT+  , getHydrationMode+  , addHydrationStep+  , addHydrationStepWithSetup+  , setPreviousNode+  , insertAfterPreviousNode+  , hydrateComment+  , askParent+  , askEvents+  , append+  , textNodeInternal+  , removeSubsequentNodes+  , deleteBetweenExclusive+  , extractBetweenExclusive+  , deleteUpTo+  , extractUpTo+  , SupportsHydrationDomBuilder+  , collectUpTo+  , collectUpToGivenParent+  , EventTriggerRef (..)+  , EventFilterTriggerRef (..)+  , wrap+  , elementInternal+  , HydrationDomSpace+  , GhcjsDomSpace+  , GhcjsDomHandler (..)+  , GhcjsDomHandler1 (..)+  , GhcjsDomEvent (..)+  , GhcjsEventFilter (..)+  , Pair1 (..)+  , Maybe1 (..)+  , GhcjsEventSpec (..)+  , HasDocument (..)+  , ghcjsEventSpec_filters+  , ghcjsEventSpec_handler+  , GhcjsEventHandler (..)+  , drawChildUpdate+  , ChildReadyState (..)+  , mkHasFocus+  , insertBefore+  , EventType+  , defaultDomEventHandler+  , defaultDomWindowEventHandler+  , withIsEvent+  , showEventName+  , elementOnEventName+  , windowOnEventName+  , wrapDomEvent+  , subscribeDomEvent+  , wrapDomEventMaybe+  , wrapDomEventsMaybe+  , getKeyEvent+  , getMouseEventCoords+  , getTouchEvent+  , WindowConfig (..)+  , Window (..)+  , wrapWindow+  -- * Internal+  , traverseDMapWithKeyWithAdjust'+  , hoistTraverseWithKeyWithAdjust+  , traverseIntMapWithKeyWithAdjust'+  , hoistTraverseIntMapWithKeyWithAdjust+  ) where++import Control.Concurrent+import Control.Exception (bracketOnError)+import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)+import Control.Monad.Exception+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict (StateT, mapStateT, get, modify', gets, runStateT)+import Data.Bitraversable+import Data.Default+import Data.Dependent.Map (DMap)+import Data.Dependent.Sum+import Data.FastMutableIntMap (PatchIntMap (..))+import Data.Foldable (for_, traverse_)+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Misc+import Data.Functor.Product+import Data.IORef+import Data.IntMap.Strict (IntMap)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Some (Some(..))+import Data.Text (Text)+import Foreign.JavaScript.Internal.Utils+import Foreign.JavaScript.TH+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)+import GHCJS.DOM.EventM (EventM, event, on)+import GHCJS.DOM.KeyboardEvent as KeyboardEvent+import GHCJS.DOM.MouseEvent+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)+import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)+import GHCJS.DOM.UIEvent+import Language.Javascript.JSaddle (call, eval)+import Reflex.Adjustable.Class+import Reflex.Class as Reflex+import Reflex.Dom.Builder.Class+import Reflex.Dynamic+import Reflex.Host.Class+import Reflex.Patch.DMapWithMove (PatchDMapWithMove(..))+import Reflex.Patch.MapWithMove (PatchMapWithMove(..))+import Reflex.PerformEvent.Base (PerformEventT)+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Base (PostBuildT)+import Reflex.PostBuild.Class+#ifdef PROFILE_REFLEX+import Reflex.Profiled+#endif+import Reflex.Requester.Base+import Reflex.Requester.Class+import Reflex.Spider (Spider, SpiderHost, Global)+import Reflex.TriggerEvent.Base hiding (askEvents)+import Reflex.TriggerEvent.Class++import qualified Data.Dependent.Map as DMap+import qualified Data.FastMutableIntMap as FastMutableIntMap+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified GHCJS.DOM as DOM+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events+import qualified GHCJS.DOM.DocumentOrShadowRoot as Document+import qualified GHCJS.DOM.Element as Element+import qualified GHCJS.DOM.Event as Event+import qualified GHCJS.DOM.EventM as DOM+import qualified GHCJS.DOM.FileList as FileList+import qualified GHCJS.DOM.GlobalEventHandlers as Events+import qualified GHCJS.DOM.HTMLInputElement as Input+import qualified GHCJS.DOM.HTMLSelectElement as Select+import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea+import qualified GHCJS.DOM.Node as Node+import qualified GHCJS.DOM.Text as DOM+import qualified GHCJS.DOM.Touch as Touch+import qualified GHCJS.DOM.TouchEvent as TouchEvent+import qualified GHCJS.DOM.TouchList as TouchList+import qualified GHCJS.DOM.Types as DOM+import qualified GHCJS.DOM.Window as Window+import qualified Reflex.Patch.DMap as PatchDMap+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)++#ifndef USE_TEMPLATE_HASKELL+import Data.Functor.Contravariant (phantom)+import Control.Lens (Lens', Getter)+#endif++#ifndef ghcjs_HOST_OS+import GHCJS.DOM.Types (MonadJSM (..))++instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where+  {-# INLINABLE liftJSM' #-}+  liftJSM' = lift . liftJSM'++instance MonadJSM m => MonadJSM (HydrationDomBuilderT s t m) where+  {-# INLINABLE liftJSM' #-}+  liftJSM' = lift . liftJSM'++instance MonadJSM m => MonadJSM (DomRenderHookT t m) where+  {-# INLINABLE liftJSM' #-}+  liftJSM' = lift . liftJSM'+#endif++data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv+  { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document+  -- ^ Reference to the document+  , _hydrationDomBuilderEnv_parent :: !(Either Node (IORef Node))+  -- ^ This is in an IORef because in the time up to hydration we can't actually know what the+  -- parent is - we populate this reference during the DOM traversal at hydration time+  , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word)+  -- ^ Number of children who still aren't fully rendered+  , _hydrationDomBuilderEnv_commitAction :: !(JSM ())+  -- ^ Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it+  , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)+  -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished+  , _hydrationDomBuilderEnv_switchover :: !(Event t ())+  , _hydrationDomBuilderEnv_delayed :: {-# UNPACK #-} !(IORef (HydrationRunnerT t m ()))+  }++-- | A monad for DomBuilder which just gets the results of children and pushes+-- work into an action that is delayed until after postBuild (to match the+-- static builder). The action runs in 'HydrationRunnerT', which performs the+-- DOM takeover and sets up the events, after which point this monad will+-- continue in the vein of 'ImmediateDomBuilderT'.+newtype HydrationDomBuilderT s t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (DomRenderHookT t m) a }+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException+#if MIN_VERSION_base(4,9,1)+           , MonadAsyncException+#endif+           )++instance PrimMonad m => PrimMonad (HydrationDomBuilderT s t m) where+  type PrimState (HydrationDomBuilderT s t m) = PrimState m+  primitive = lift . primitive++instance MonadTrans (HydrationDomBuilderT s t) where+  lift = HydrationDomBuilderT . lift . lift++instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m) where+  withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT+  requestDomAction = HydrationDomBuilderT . lift . requestDomAction+  requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_++-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.+-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.+newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT HydrationState (ReaderT Node (DomRenderHookT t m)) a }+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException+#if MIN_VERSION_base(4,9,1)+           , MonadAsyncException+#endif+           )++data HydrationState = HydrationState+  { _hydrationState_previousNode :: !(Maybe Node)+  , _hydrationState_failed :: !Bool+  }++{-# INLINABLE localRunner #-}+localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a+localRunner (HydrationRunnerT m) s parent = do+  s0 <- HydrationRunnerT get+  (a, s') <- HydrationRunnerT $ lift $ local (\_ -> parent) $ runStateT m (s0 { _hydrationState_previousNode = s })+  traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'+  HydrationRunnerT $ modify' $ \hs -> hs { _hydrationState_failed = _hydrationState_failed s' }+  pure a++{-# INLINABLE runHydrationRunnerT #-}+runHydrationRunnerT+  :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))+  => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a+runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do+  (a, s') <- runStateT m (HydrationState s False)+  traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'+  when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."+  pure a++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where+  {-# INLINABLE newEventWithTrigger #-}+  newEventWithTrigger = lift . newEventWithTrigger+  {-# INLINABLE newFanEventWithTrigger #-}+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance MonadTrans (HydrationRunnerT t) where+  {-# INLINABLE lift #-}+  lift = HydrationRunnerT . lift . lift . lift++instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where+  {-# INLINABLE sample #-}+  sample = lift . sample++instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where+  withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT+  requestDomAction = HydrationRunnerT . lift . lift . requestDomAction+  requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_++-- | Add a hydration step which depends on some computation that should only be+-- done *before* the switchover to immediate mode - this is most likely some+-- form of 'hold' which we want to remove after hydration is done+{-# INLINABLE addHydrationStepWithSetup #-}+addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()+addHydrationStepWithSetup setup f = getHydrationMode >>= \case+  HydrationMode_Immediate -> pure ()+  HydrationMode_Hydrating -> do+    switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover+    (s, _) <- lift $ runWithReplace setup $ return () <$ switchover+    addHydrationStep (f s)++-- | Add a hydration step+{-# INLINABLE addHydrationStep #-}+addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT s t m ()+addHydrationStep m = do+  delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed+  liftIO $ modifyIORef' delayedRef (>> m)++-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT+newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException+#if MIN_VERSION_base(4,9,1)+           , MonadAsyncException+#endif+           )++{-# INLINABLE runDomRenderHookT #-}+runDomRenderHookT+  :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)+  => DomRenderHookT t m a+  -> Chan [DSum (EventTriggerRef t) TriggerInvocation]+  -> m a+runDomRenderHookT (DomRenderHookT a) events = do+  flip runTriggerEventT events $ do+    rec (result, req) <- runRequesterT a rsp+        rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $+          traverseRequesterData (\r -> Identity <$> r) rm+    return result+  where+    runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do+        v <- synchronously x+        void . liftIO $ f v++instance MonadTrans (DomRenderHookT t) where+  {-# INLINABLE lift #-}+  lift = DomRenderHookT . lift . lift++instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where+  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)+  requestDomAction = DomRenderHookT . requestingIdentity+  requestDomAction_ = DomRenderHookT . requesting_++{-# INLINABLE runHydrationDomBuilderT #-}+runHydrationDomBuilderT+  :: ( MonadFix m+     , PerformEvent t m+     , MonadReflexCreateTrigger t m+     , MonadJSM m+     , MonadJSM (Performable m)+     , MonadRef m+     , Ref m ~ IORef+     )+  => HydrationDomBuilderT s t m a+  -> HydrationDomBuilderEnv t m+  -> Chan [DSum (EventTriggerRef t) TriggerInvocation]+  -> m a+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)++instance (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, Monad m) => HasDocument (HydrationDomBuilderT s t m) where+  {-# INLINABLE askDocument #-}+  askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document++{-# INLINABLE askParent #-}+askParent :: Monad m => HydrationRunnerT t m DOM.Node+askParent = HydrationRunnerT ask++{-# INLINABLE getParent #-}+getParent :: MonadIO m => HydrationDomBuilderT s t m DOM.Node+getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)++{-# INLINABLE askEvents #-}+askEvents :: Monad m => HydrationDomBuilderT s t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])+askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents++{-# INLINABLE localEnv #-}+localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT s t m a -> HydrationDomBuilderT s t m a+localEnv f = HydrationDomBuilderT . local (f $!) . unHydrationDomBuilderT++{-# INLINABLE append #-}+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT s t m ()+append n = do+  p <- getParent+  liftJSM $ appendChild_ p n+  return ()++{-# SPECIALIZE append+  :: DOM.Node+  -> HydrationDomBuilderT s Spider HydrationM ()+  #-}++data HydrationMode+  = HydrationMode_Hydrating+  -- ^ The time from initial load to parity with static builder+  | HydrationMode_Immediate+  -- ^ After hydration+  deriving (Eq, Ord, Show)++{-# INLINABLE getPreviousNode #-}+getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)+getPreviousNode = HydrationRunnerT $ gets _hydrationState_previousNode++{-# INLINABLE setPreviousNode #-}+setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()+setPreviousNode n = HydrationRunnerT $ modify' (\hs -> hs { _hydrationState_previousNode = n })++{-# INLINABLE askUnreadyChildren #-}+askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)+askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren++{-# INLINABLE askCommitAction #-}+askCommitAction :: Monad m => HydrationDomBuilderT s t m (JSM ())+askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction++{-# INLINABLE getHydrationMode #-}+getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode+getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)++-- | Remove all nodes after given node+removeSubsequentNodes :: (MonadJSM m, IsNode n) => n -> m ()+removeSubsequentNodes n = liftJSM $ do+  f <- eval ("(function(n) { while (n.nextSibling) { (n.parentNode).removeChild(n.nextSibling); }; })" :: Text)+  void $ call f f [n]++-- | s and e must both be children of the same node and s must precede e;+--   all nodes between s and e will be removed, but s and e will not be removed+deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()+deleteBetweenExclusive s e = liftJSM $ do+  df <- createDocumentFragment =<< getOwnerDocumentUnchecked s+  extractBetweenExclusive df s e -- In many places in ImmediateDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant++-- | s and e must both be children of the same node and s must precede e; all+--   nodes between s and e will be moved into the given DocumentFragment, but s+--   and e will not be moved+extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()+extractBetweenExclusive df s e = liftJSM $ do+  f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text)+  void $ call f f (df, s, e)++-- | s and e must both be children of the same node and s must precede e;+--   s and all nodes between s and e will be removed, but e will not be removed+{-# INLINABLE deleteUpTo #-}+deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()+deleteUpTo s e = do+  df <- createDocumentFragment =<< getOwnerDocumentUnchecked s+  extractUpTo df s e -- In many places in ImmediateDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant++extractUpTo :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()+#ifdef ghcjs_HOST_OS+--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04)+foreign import javascript unsafe+  "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"+  extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()+extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e)+#else+extractUpTo df s e = liftJSM $ do+  f <- eval ("(function(df,s,e){ var x = s; var y; for(;;) { y = x['nextSibling']; df['appendChild'](x); if(e===y) { break; } x = y; } })" :: Text)+  void $ call f f (df, s, e)+#endif++type SupportsHydrationDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, Adjustable t m, PrimMonad m, PerformEvent t m, MonadJSM (Performable m))++{-# INLINABLE collectUpTo #-}+collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment+collectUpTo s e = do+  currentParent <- getParentNodeUnchecked e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment+  collectUpToGivenParent currentParent s e++{-# INLINABLE collectUpToGivenParent #-}+collectUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment+collectUpToGivenParent currentParent s e = do+  doc <- getOwnerDocumentUnchecked currentParent+  df <- createDocumentFragment doc+  extractUpTo df s e+  return df++newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))++-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself+{-# INLINE wrap #-}+wrap+  :: forall s m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m, EventSpec s ~ GhcjsEventSpec)+  => Chan [DSum (EventTriggerRef t) TriggerInvocation]+  -> DOM.Element+  -> RawElementConfig er t s+  -> m (DMap EventName (EventFilterTriggerRef t er))+wrap events e cfg = do+  forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of+    Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv+    Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv+  eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do+    triggerRef <- liftIO $ newIORef Nothing+    _ <- elementOnEventName en e $ do --TODO: Something safer than this cast+      evt <- DOM.event+      (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt+      when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault+      case _eventFlags_propagation flags of+        Propagation_Continue -> return ()+        Propagation_Stop -> withIsEvent en DOM.stopPropagation+        Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation+      mv <- liftJSM k --TODO: Only do this when the event is subscribed+      liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]+    return $ en :=> EventFilterTriggerRef triggerRef+  return eventTriggerRefs++{-# SPECIALIZE wrap+  :: Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]+  -> DOM.Element+  -> RawElementConfig er DomTimeline HydrationDomSpace+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (DMap EventName (EventFilterTriggerRef DomTimeline er))+  #-}++{-# SPECIALIZE wrap+  :: Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]+  -> DOM.Element+  -> RawElementConfig er DomTimeline GhcjsDomSpace+  -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (DMap EventName (EventFilterTriggerRef DomTimeline er))+  #-}++{-# INLINE triggerBody #-}+triggerBody+  :: forall s er t x. EventSpec s ~ GhcjsEventSpec+  => DOM.JSContextRef+  -> RawElementConfig er t s+  -> Chan [DSum (EventTriggerRef t) TriggerInvocation]+  -> DMap EventName (EventFilterTriggerRef t er)+  -> DOM.Element+  -> WrapArg er EventName x+  -> EventTrigger t x+  -> IO (IO ())+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of+  Just (EventFilterTriggerRef r) -> do+    writeIORef r $ Just t+    return $ do+      writeIORef r Nothing+  Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do+    evt <- DOM.event+    mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)+    case mv of+      Nothing -> return ()+      Just v -> liftIO $ do+        --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+        ref <- newIORef $ Just t+        writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])+  where+    -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't+    -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up+    handler :: GhcjsEventHandler er+    !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg++{-# SPECIALIZE triggerBody+  :: DOM.JSContextRef+  -> RawElementConfig er DomTimeline HydrationDomSpace+  -> Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]+  -> DMap EventName (EventFilterTriggerRef DomTimeline er)+  -> DOM.Element+  -> WrapArg er EventName x+  -> EventTrigger DomTimeline x+  -> IO (IO ())+  #-}++{-# SPECIALIZE triggerBody+  :: DOM.JSContextRef+  -> RawElementConfig er DomTimeline GhcjsDomSpace+  -> Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]+  -> DMap EventName (EventFilterTriggerRef DomTimeline er)+  -> DOM.Element+  -> WrapArg er EventName x+  -> EventTrigger DomTimeline x+  -> IO (IO ())+  #-}++newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }++newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> JSM (b x) }++newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }++data GhcjsDomSpace++instance DomSpace GhcjsDomSpace where+  type EventSpec GhcjsDomSpace = GhcjsEventSpec+  type RawDocument GhcjsDomSpace = DOM.Document+  type RawTextNode GhcjsDomSpace = DOM.Text+  type RawCommentNode GhcjsDomSpace = DOM.Comment+  type RawElement GhcjsDomSpace = DOM.Element+  type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement+  type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement+  type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement+  addEventSpecFlags _ en f es = es+    { _ghcjsEventSpec_filters =+        let f' = Just . GhcjsEventFilter . \case+              Nothing -> \evt -> do+                mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)+                return (f mEventResult, return mEventResult)+              Just (GhcjsEventFilter oldFilter) -> \evt -> do+                (oldFlags, oldContinuation) <- oldFilter evt+                mEventResult <- oldContinuation+                let newFlags = oldFlags <> f mEventResult+                return (newFlags, return mEventResult)+        in DMap.alter f' en $ _ghcjsEventSpec_filters es+    }++newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> JSM (EventFlags, JSM (Maybe (er en))))++data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)++data Maybe1 f a = Nothing1 | Just1 (f a)++data GhcjsEventSpec er = GhcjsEventSpec+  { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)+  , _ghcjsEventSpec_handler :: GhcjsEventHandler er+  }++newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }++#ifndef USE_TEMPLATE_HASKELL+ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))+ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a+{-# INLINE ghcjsEventSpec_filters #-}+ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))+ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom (f b)+{-# INLINE ghcjsEventSpec_handler #-}+#endif++instance er ~ EventResult => Default (GhcjsEventSpec er) where+  def = GhcjsEventSpec+    { _ghcjsEventSpec_filters = mempty+    , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> do+        t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument+        let e = uncheckedCastTo DOM.Element t+        runReaderT (defaultDomEventHandler e en) evt+    }++{-# INLINE makeElement #-}+makeElement :: MonadJSM m => Document -> Text -> ElementConfig er t s -> m DOM.Element+makeElement doc elementTag cfg = do+  e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of+    Nothing -> createElement doc elementTag+    Just ens -> createElementNS doc (Just ens) elementTag+  iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of+    Nothing -> setAttribute e n v+    Just ans -> setAttributeNS e (Just ans) n v+  pure e++{-# INLINE elementImmediate #-}+elementImmediate+  :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec+     , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m )+  => Text+  -> ElementConfig er t s+  -> HydrationDomBuilderT s t m a+  -> HydrationDomBuilderT s t m (Element er GhcjsDomSpace t, a)+elementImmediate elementTag cfg child = do+  doc <- askDocument+  ctx <- askJSM+  events <- askEvents+  parent <- getParent+  e <- makeElement doc elementTag cfg+  appendChild_ parent e+  -- Run the child builder with updated parent and previous sibling references+  result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child+  let rawCfg = extractRawElementConfig cfg+  eventTriggerRefs <- wrap events e rawCfg+  es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e+  return (Element es e, result)++{-# SPECIALIZE elementImmediate+  :: Text+  -> ElementConfig er DomTimeline HydrationDomSpace+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)+  #-}++{-# SPECIALIZE elementImmediate+  :: Text+  -> ElementConfig er DomTimeline GhcjsDomSpace+  -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM a+  -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)+  #-}++-- For specialisation++-- | The Reflex timeline for interacting with the DOM+type DomTimeline =+#ifdef PROFILE_REFLEX+  ProfiledTimeline+#endif+  Spider++-- | The ReflexHost the DOM lives in+type DomHost =+#ifdef PROFILE_REFLEX+  ProfiledM+#endif+  (SpiderHost Global)++type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))+type HydrationM = DomCoreWidget ()++{-# INLINE elementInternal #-}+elementInternal+  :: (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)+  => Text+  -> ElementConfig er t HydrationDomSpace+  -> HydrationDomBuilderT HydrationDomSpace t m a+  -> HydrationDomBuilderT HydrationDomSpace t m (Element er HydrationDomSpace t, a)+elementInternal elementTag cfg child = getHydrationMode >>= \case+  HydrationMode_Immediate -> do+    (Element es _, result) <- elementImmediate elementTag cfg child+    return (Element es (), result)+  HydrationMode_Hydrating -> fst <$> hydrateElement elementTag cfg child++{-# SPECIALIZE elementInternal+  :: Text+  -> ElementConfig er DomTimeline HydrationDomSpace+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)+  #-}++{-# INLINE hydrateElement #-}+hydrateElement+  :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)+  => Text+  -> ElementConfig er t HydrationDomSpace+  -> HydrationDomBuilderT HydrationDomSpace t m a+  -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)+hydrateElement elementTag cfg child = do+  ctx <- askJSM+  events <- askEvents+  -- Schedule everything for after postBuild, except for getting the result itself+  parentRef <- liftIO $ newIORef $ error "Parent not yet initialized"+  e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"+  env <- HydrationDomBuilderT ask+  childDelayedRef <- liftIO $ newIORef $ pure ()+  let env' = env+        { _hydrationDomBuilderEnv_parent = Right parentRef+        , _hydrationDomBuilderEnv_delayed = childDelayedRef+        }+  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+  childDom <- liftIO $ readIORef childDelayedRef+  let rawCfg = extractRawElementConfig cfg+  doc <- askDocument+  addHydrationStep $ do+    parent <- askParent+    lastHydrationNode <- getPreviousNode+    let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case+          Nothing -> do -- ran out of nodes, create the element+            HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }+            e <- makeElement doc elementTag cfg+            insertAfterPreviousNode e+            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+                t <- Element.getTagName e+                -- TODO: check attributes?+                if T.toCaseFold elementTag == T.toCaseFold t+                  then pure e+                  -- we came to some other statically rendered element, so something has gone wrong+                  else do+                    HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }+                    n <- makeElement doc elementTag cfg+                    insertAfterPreviousNode n+                    pure n+    e <- go lastHydrationNode+    setPreviousNode $ Just $ toNode e+    -- Update the parent node used by the children+    liftIO $ writeIORef parentRef $ toNode e+    liftIO $ writeIORef e' e+    -- Setup events, store the result so we can wait on it later+    refs <- wrap events e rawCfg+    liftIO $ putMVar wrapResult (e, refs)+    localRunner childDom Nothing $ toNode e+  -- We need the EventSelector to switch to the real event handler after activation+  es <- newFanEventWithTrigger $ \(WrapArg en) t -> do+    cleanup <- newEmptyMVar+    threadId <- forkIO $ do+      -- Wait on the data we need from the delayed action+      (e, eventTriggerRefs) <- readMVar wrapResult+      bracketOnError+        -- Run the setup, acquiring the cleanup action+        (triggerBody ctx rawCfg events eventTriggerRefs e (WrapArg en) t)+        -- Run the cleanup, if we have it - but only when an exception is+        -- raised (we might get killed between acquiring the cleanup action+        -- from 'triggerBody' and putting it in the MVar)+        id+        -- Try to put this action into the cleanup MVar+        (putMVar cleanup)+    pure $ do+      tryReadMVar cleanup >>= \case+        Nothing -> killThread threadId+        Just c -> c+  return ((Element es (), result), e')++{-# SPECIALIZE hydrateElement+  :: Text+  -> ElementConfig er DomTimeline HydrationDomSpace+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM ((Element er HydrationDomSpace DomTimeline, a), IORef DOM.Element)+  #-}++{-# INLINE inputElementImmediate #-}+inputElementImmediate+  :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec+     , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m+     , MonadRef m, Ref m ~ IORef )+  => InputElementConfig er t s -> HydrationDomBuilderT s t m (InputElement er GhcjsDomSpace t)+inputElementImmediate cfg = do+  (e@(Element eventSelector domElement), ()) <- elementImmediate "input" (_inputElementConfig_elementConfig cfg) $ return ()+  let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement+  Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue+  v0 <- Input.getValue domInputElement+  let getMyValue = Input.getValue domInputElement+  valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)+  valueChangedBySetValue <- case _inputElementConfig_setValue cfg of+    Nothing -> return never+    Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do+      Input.setValue domInputElement v'+      getMyValue -- We get the value after setting it in case the browser has mucked with it somehow+  v <- holdDyn v0 $ leftmost+    [ valueChangedBySetValue+    , valueChangedByUI+    ]+  Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg+  checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do+    Input.getChecked domInputElement+  checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of+    Nothing -> return never+    Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do+      oldChecked <- Input.getChecked domInputElement+      Input.setChecked domInputElement newChecked+      return $ if newChecked /= oldChecked+                  then Just newChecked+                  else Nothing+  c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost+    [ fmapMaybe id checkedChangedBySetChecked+    , checkedChangedByUI+    ]+  hasFocus <- mkHasFocus e+  files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do+    mfiles <- Input.getFiles domInputElement+    let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs+    maybe (return []) getMyFiles mfiles+  checked <- holdUniqDyn c+  return $ InputElement+    { _inputElement_value = v+    , _inputElement_checked = checked+    , _inputElement_checkedChange =  checkedChangedByUI+    , _inputElement_input = valueChangedByUI+    , _inputElement_hasFocus = hasFocus+    , _inputElement_element = e+    , _inputElement_raw = domInputElement+    , _inputElement_files = files+    }++{-# INLINE inputElementInternal #-}+inputElementInternal+  :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m+     , MonadRef m, Ref m ~ IORef )+  => InputElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (InputElement er HydrationDomSpace t)+inputElementInternal cfg = getHydrationMode >>= \case+  HydrationMode_Immediate -> ffor (inputElementImmediate cfg) $ \result -> result+    { _inputElement_element = Element (_element_events $ _inputElement_element result) ()+    , _inputElement_raw = ()+    }+  HydrationMode_Hydrating -> do+  ((e, _), domElementRef) <- hydrateElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()+  (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent+  (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent+  (focusChange, triggerFocusChange) <- newTriggerEvent+  (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent+  (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent+  (fileChange, triggerFileChange) <- newTriggerEvent+  doc <- askDocument+  -- Expected initial value from config+  let v0 = _inputElementConfig_initialValue cfg+  addHydrationStep $ do+    domElement <- liftIO $ readIORef domElementRef+    let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement+        getValue = Input.getValue domInputElement+    -- The browser might have messed with the value, or the user could have+    -- altered it before activation, so we set it if it isn't what we expect+    liftJSM getValue >>= \v0' -> do+      when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'+    -- Watch for user interaction and trigger event accordingly+    requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)+    for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->+      requestDomAction_ $ ffor eSetValue $ \v' -> do+        Input.setValue domInputElement v'+        v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow+        liftIO $ triggerChangeBySetValue v+    let focusChange' = leftmost+          [ False <$ Reflex.select (_element_events e) (WrapArg Blur)+          , True <$ Reflex.select (_element_events e) (WrapArg Focus)+          ]+    liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc+    requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'+    Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg+    _ <- liftJSM $ domInputElement `on` Events.click $ do+      liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement+    for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->+      requestDomAction $ ffor eNewchecked $ \newChecked -> do+        oldChecked <- Input.getChecked domInputElement+        Input.setChecked domInputElement newChecked+        when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked+    _ <- liftJSM $ domInputElement `on` Events.change $ do+      mfiles <- Input.getFiles domInputElement+      let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs+      liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles+    return ()+  checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost+    [ checkedChangedBySetChecked+    , checkedChangedByUI+    ]+  checked <- holdUniqDyn checked'+  let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover+  hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange+  v <- holdDyn v0 $ leftmost+    [ valueChangedBySetValue+    , valueChangedByUI+    ]+  files <- holdDyn mempty fileChange+  return $ InputElement+    { _inputElement_value = v+    , _inputElement_checked = checked+    , _inputElement_checkedChange = checkedChangedByUI+    , _inputElement_input = valueChangedByUI+    , _inputElement_hasFocus = hasFocus+    , _inputElement_element = e+    , _inputElement_raw = ()+    , _inputElement_files = files+    }++{-# INLINE textAreaElementImmediate #-}+textAreaElementImmediate+  :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec+     , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m+     , MonadRef m, Ref m ~ IORef )+  => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t)+textAreaElementImmediate cfg = do+  (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()+  let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement+  TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue+  v0 <- TextArea.getValue domTextAreaElement+  let getMyValue = TextArea.getValue domTextAreaElement+  valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)+  valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of+    Nothing -> return never+    Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do+      TextArea.setValue domTextAreaElement v'+      getMyValue -- We get the value after setting it in case the browser has mucked with it somehow+  v <- holdDyn v0 $ leftmost+    [ valueChangedBySetValue+    , valueChangedByUI+    ]+  hasFocus <- mkHasFocus e+  return $ TextAreaElement+    { _textAreaElement_value = v+    , _textAreaElement_input = valueChangedByUI+    , _textAreaElement_hasFocus = hasFocus+    , _textAreaElement_element = e+    , _textAreaElement_raw = domTextAreaElement+    }++{-# INLINE textAreaElementInternal #-}+textAreaElementInternal+  :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m+     , MonadRef m, Ref m ~ IORef )+    => TextAreaElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (TextAreaElement er HydrationDomSpace t)+textAreaElementInternal cfg = getHydrationMode >>= \case+  HydrationMode_Immediate -> ffor (textAreaElementImmediate cfg) $ \result -> result+    { _textAreaElement_element = Element (_element_events $ _textAreaElement_element result) ()+    , _textAreaElement_raw = ()+    }+  HydrationMode_Hydrating -> do+  ((e, _), domElementRef) <- hydrateElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()+  (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent+  (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent+  (focusChange, triggerFocusChange) <- newTriggerEvent+  doc <- askDocument+  -- Expected initial value from config+  let v0 = _textAreaElementConfig_initialValue cfg+  addHydrationStep $ do+    domElement <- liftIO $ readIORef domElementRef+    let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement+        getValue = TextArea.getValue domTextAreaElement+    -- The browser might have messed with the value, or the user could have+    -- altered it before activation, so we set it if it isn't what we expect+    liftJSM getValue >>= \v0' -> do+      when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'+    -- Watch for user interaction and trigger event accordingly+    requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)+    for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->+      requestDomAction_ $ ffor eSetValue $ \v' -> do+        TextArea.setValue domTextAreaElement v'+        v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow+        liftIO $ triggerChangeBySetValue v+    let focusChange' = leftmost+          [ False <$ Reflex.select (_element_events e) (WrapArg Blur)+          , True <$ Reflex.select (_element_events e) (WrapArg Focus)+          ]+    liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc+    requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'+  let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover+  hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange+  v <- holdDyn v0 $ leftmost+    [ valueChangedBySetValue+    , valueChangedByUI+    ]+  return $ TextAreaElement+    { _textAreaElement_value = v+    , _textAreaElement_input = valueChangedByUI+    , _textAreaElement_hasFocus = hasFocus+    , _textAreaElement_element = e+    , _textAreaElement_raw = ()+    }++{-# INLINE selectElementImmediate #-}+selectElementImmediate+  :: ( EventSpec s ~ GhcjsEventSpec, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document+     , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m )+  => SelectElementConfig er t s+  -> HydrationDomBuilderT s t m a+  -> HydrationDomBuilderT s t m (SelectElement er GhcjsDomSpace t, a)+selectElementImmediate cfg child = do+  (e@(Element eventSelector domElement), result) <- elementImmediate "select" (cfg ^. selectElementConfig_elementConfig) child+  let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement+  Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue+  v0 <- Select.getValue domSelectElement+  let getMyValue = Select.getValue domSelectElement+  valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Change)+  valueChangedBySetValue <- case _selectElementConfig_setValue cfg of+    Nothing -> return never+    Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do+      Select.setValue domSelectElement v'+      getMyValue -- We get the value after setting it in case the browser has mucked with it somehow+  v <- holdDyn v0 $ leftmost+    [ valueChangedBySetValue+    , valueChangedByUI+    ]+  hasFocus <- mkHasFocus e+  let wrapped = SelectElement+        { _selectElement_value = v+        , _selectElement_change = valueChangedByUI+        , _selectElement_hasFocus = hasFocus+        , _selectElement_element = e+        , _selectElement_raw = domSelectElement+        }+  return (wrapped, result)++{-# INLINE selectElementInternal #-}+selectElementInternal+  :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m+     , MonadRef m, Ref m ~ IORef )+    => SelectElementConfig er t HydrationDomSpace+    -> HydrationDomBuilderT HydrationDomSpace t m a+    -> HydrationDomBuilderT HydrationDomSpace t m (SelectElement er HydrationDomSpace t, a)+selectElementInternal cfg child = getHydrationMode >>= \case+  HydrationMode_Immediate -> ffor (selectElementImmediate cfg child) $ \(e, result) -> (e+    { _selectElement_element = Element (_element_events $ _selectElement_element e) ()+    , _selectElement_raw = ()+    }, result)+  HydrationMode_Hydrating -> do+  ((e, result), domElementRef) <- hydrateElement "select" (cfg ^. selectElementConfig_elementConfig) child+  (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent+  (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent+  (focusChange, triggerFocusChange) <- newTriggerEvent+  doc <- askDocument+  -- Expected initial value from config+  let v0 = _selectElementConfig_initialValue cfg+  addHydrationStep $ do+    domElement <- liftIO $ readIORef domElementRef+    let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement+        getValue = Select.getValue domSelectElement+    -- The browser might have messed with the value, or the user could have+    -- altered it before activation, so we set it if it isn't what we expect+    liftJSM getValue >>= \v0' -> do+      when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'+    -- Watch for user interaction and trigger event accordingly+    requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)+    for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->+      requestDomAction_ $ ffor eSetValue $ \v' -> do+        Select.setValue domSelectElement v'+        v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow+        liftIO $ triggerChangeBySetValue v+    let focusChange' = leftmost+          [ False <$ Reflex.select (_element_events e) (WrapArg Blur)+          , True <$ Reflex.select (_element_events e) (WrapArg Focus)+          ]+    liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc+    requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'+  let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover+  hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange+  v <- holdDyn v0 $ leftmost+    [ valueChangedBySetValue+    , valueChangedByUI+    ]+  return $ (,result) $ SelectElement+    { _selectElement_value = v+    , _selectElement_change = valueChangedByUI+    , _selectElement_hasFocus = hasFocus+    , _selectElement_element = e+    , _selectElement_raw = ()+    }++{-# INLINE textNodeImmediate #-}+textNodeImmediate+  :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)+  => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text+textNodeImmediate (TextNodeConfig !t mSetContents) = do+  p <- getParent+  doc <- askDocument+  n <- createTextNode doc t+  appendChild_ p n+  mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents+  pure n++{-# SPECIALIZE textNodeImmediate+  :: TextNodeConfig DomTimeline+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text+  #-}++{-# SPECIALIZE textNodeImmediate+  :: TextNodeConfig DomTimeline+  -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text+  #-}++{-# INLINE textNodeInternal #-}+textNodeInternal+  :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)+  => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)+textNodeInternal tc@(TextNodeConfig !t mSetContents) = do+  doc <- askDocument+  getHydrationMode >>= \case+    HydrationMode_Immediate -> void $ textNodeImmediate tc+    HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do+      n <- hydrateTextNode doc =<< sample currentText+      mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents+  pure $ TextNode ()++{-# SPECIALIZE textNodeInternal+  :: TextNodeConfig DomTimeline+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)+  #-}++-- | The static builder mashes adjacent text nodes into one node: we check the+-- text content of each node we come to, comparing it to the content we+-- expect. We also have a special case for empty text nodes - we always create+-- the and add them after the previous node reference.+{-# INLINE hydrateTextNode #-}+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text+hydrateTextNode doc t@"" = do+  tn <- createTextNode doc t+  insertAfterPreviousNode tn+  pure tn+hydrateTextNode doc t = do+  n <- join $ go <$> askParent <*> getPreviousNode+  setPreviousNode $ Just $ toNode n+  return n+  where+    go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case+      Nothing -> do+        HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }+        n <- createTextNode doc t+        insertAfterPreviousNode n+        pure n+      Just node -> DOM.castTo DOM.Text node >>= \case+        Nothing -> go parent $ Just node+        Just originalNode -> do+          originalText <- Node.getTextContentUnchecked originalNode+          case T.stripPrefix t originalText of+            Just "" -> return originalNode+            Just _ -> do+              -- If we have the right prefix, we split the text node into a node containing the+              -- required text and a subsequent sibling node containing the rest of the text.+              DOM.splitText_ originalNode $ fromIntegral $ T.length t+              return originalNode+            Nothing -> do+              HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }+              n <- createTextNode doc t+              insertAfterPreviousNode n+              pure n++{-# INLINE commentNodeImmediate #-}+commentNodeImmediate+  :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)+  => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment+commentNodeImmediate (CommentNodeConfig !t mSetContents) = do+  p <- getParent+  doc <- askDocument+  n <- createComment doc t+  appendChild_ p n+  mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents+  pure n++{-# INLINE commentNodeInternal #-}+commentNodeInternal+  :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m, MonadHold t m, MonadSample t m)+  => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)+commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do+  doc <- askDocument+  getHydrationMode >>= \case+    HydrationMode_Immediate -> void $ commentNodeInternal tc+    HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do+      t <- sample bt+      void $ hydrateComment doc t mSetContents+  pure $ CommentNode ()++{-# INLINE hydrateComment #-}+hydrateComment :: (MonadJSM m, Reflex t, MonadFix m) => Document -> Text -> Maybe (Event t Text) -> HydrationRunnerT t m DOM.Comment+hydrateComment doc t mSetContents = do+  parent <- askParent+  let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case+        Nothing -> do+          c <- createComment doc t+          insertAfterPreviousNode c+          pure c+        Just node -> DOM.castTo DOM.Comment node >>= \case+          Nothing -> go (Just node)+          Just c -> do+            t' <- Node.getTextContentUnchecked c+            if t == t'+              then pure c+              else do+                c' <- createComment doc t+                insertAfterPreviousNode c'+                pure c'+  n <- go =<< getPreviousNode+  setPreviousNode $ Just $ toNode n+  mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents+  pure n++-- | We leave markers in the static builder as comments, and rip these comments+-- out at hydration time, replacing them with empty text nodes.+{-# INLINABLE skipToAndReplaceComment #-}+skipToAndReplaceComment+  :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)+  => Text+  -> IORef Text+  -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case+  HydrationMode_Immediate -> do+    -- If we're in immediate mode, we don't try to replace an existing comment,+    -- and just return a dummy key+    t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing+    append $ toNode t+    textNodeRef <- liftIO $ newIORef t+    keyRef <- liftIO $ newIORef ""+    pure (pure (), textNodeRef, keyRef)+  HydrationMode_Hydrating -> do+    doc <- askDocument+    textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"+    keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"+    let go key0 mLastNode = do+          parent <- askParent+          node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode+          DOM.castTo DOM.Comment node >>= \case+            Just comment -> do+              commentText <- Node.getTextContentUnchecked comment+              case T.stripPrefix (prefix <> key0) commentText of+                Just key -> do+                  -- Replace the comment with an (invisible) text node+                  tn <- createTextNode doc ("" :: Text)+                  Node.replaceChild_ parent tn comment+                  pure (tn, key)+                Nothing -> do+                  go key0 (Just node)+            Nothing -> do+              go key0 (Just node)+        switchComment = do+          key0 <- liftIO $ readIORef key0Ref+          (tn, key) <- go key0 =<< getPreviousNode+          setPreviousNode $ Just $ toNode tn+          liftIO $ do+            writeIORef textNodeRef tn+            writeIORef keyRef key+    pure (switchComment, textNodeRef, keyRef)++{-# INLINABLE skipToReplaceStart #-}+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")++{-# INLINABLE skipToReplaceEnd #-}+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)+skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key++instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where+  notReadyUntil e = do+    eOnce <- headE e+    unreadyChildren <- askUnreadyChildren+    commitAction <- askCommitAction+    liftIO $ modifyIORef' unreadyChildren succ+    let ready = do+          old <- liftIO $ readIORef unreadyChildren+          let new = pred old+          liftIO $ writeIORef unreadyChildren $! new+          when (new == 0) commitAction+    requestDomAction_ $ ready <$ eOnce+  notReady = do+    unreadyChildren <- askUnreadyChildren+    liftIO $ modifyIORef' unreadyChildren succ++data HydrationDomSpace++instance DomSpace HydrationDomSpace where+  type EventSpec HydrationDomSpace = GhcjsEventSpec+  type RawDocument HydrationDomSpace = DOM.Document+  type RawTextNode HydrationDomSpace = ()+  type RawCommentNode HydrationDomSpace = ()+  type RawElement HydrationDomSpace = ()+  type RawInputElement HydrationDomSpace = ()+  type RawTextAreaElement HydrationDomSpace = ()+  type RawSelectElement HydrationDomSpace = ()+  addEventSpecFlags _ en f es = es+    { _ghcjsEventSpec_filters =+        let f' = Just . GhcjsEventFilter . \case+              Nothing -> \evt -> do+                mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)+                return (f mEventResult, return mEventResult)+              Just (GhcjsEventFilter oldFilter) -> \evt -> do+                (oldFlags, oldContinuation) <- oldFilter evt+                mEventResult <- oldContinuation+                let newFlags = oldFlags <> f mEventResult+                return (newFlags, return mEventResult)+        in DMap.alter f' en $ _ghcjsEventSpec_filters es+    }++instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT HydrationDomSpace t m) where+  type DomBuilderSpace (HydrationDomBuilderT HydrationDomSpace t m) = HydrationDomSpace+  {-# INLINABLE element #-}+  element = elementInternal+  {-# INLINABLE textNode #-}+  textNode = textNodeInternal+  {-# INLINABLE commentNode #-}+  commentNode = commentNodeInternal+  {-# INLINABLE inputElement #-}+  inputElement = inputElementInternal+  {-# INLINABLE textAreaElement #-}+  textAreaElement = textAreaElementInternal+  {-# INLINABLE selectElement #-}+  selectElement = selectElementInternal+  placeRawElement () = pure ()+  wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()++instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where+  type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace+  {-# INLINABLE element #-}+  element = elementImmediate+  {-# INLINABLE textNode #-}+  textNode = fmap TextNode . textNodeImmediate+  {-# INLINABLE commentNode #-}+  commentNode = fmap CommentNode . commentNodeImmediate+  {-# INLINABLE inputElement #-}+  inputElement = inputElementImmediate+  {-# INLINABLE textAreaElement #-}+  textAreaElement = textAreaElementImmediate+  {-# INLINABLE selectElement #-}+  selectElement = selectElementImmediate+  placeRawElement = append . toNode+  wrapRawElement e rawCfg = do+    events <- askEvents+    ctx <- askJSM+    eventTriggerRefs <- wrap events e rawCfg+    es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e+    pure $ Element es e++data FragmentState+  = FragmentState_Unmounted+  | FragmentState_Mounted (DOM.Text, DOM.Text)++data ImmediateDomFragment = ImmediateDomFragment+  { _immediateDomFragment_document :: DOM.DocumentFragment+  , _immediateDomFragment_state :: IORef FragmentState+  }++extractFragment :: MonadJSM m => ImmediateDomFragment -> m ()+extractFragment fragment = do+  state <- liftIO $ readIORef $ _immediateDomFragment_state fragment+  case state of+    FragmentState_Unmounted -> return ()+    FragmentState_Mounted (before, after) -> do+      extractBetweenExclusive (_immediateDomFragment_document fragment) before after+      liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted++instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where+  type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment+  buildDomFragment w = do+    df <- createDocumentFragment =<< askDocument+    result <- flip localEnv w $ \env -> env+      { _hydrationDomBuilderEnv_parent = Left $ toNode df+      }+    state <- liftIO $ newIORef FragmentState_Unmounted+    return (ImmediateDomFragment df state, result)+  mountDomFragment fragment setFragment = do+    parent <- getParent+    extractFragment fragment+    before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing+    appendChild_ parent $ _immediateDomFragment_document fragment+    after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing+    xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment+    requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do+      extractFragment previousFragment+      extractFragment childFragment+      insertBefore (_immediateDomFragment_document childFragment) after+      liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)+    liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)++instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where+  runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')+  traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m+  traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m+  traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m++instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Adjustable t (HydrationDomBuilderT s t m) where+  {-# INLINABLE runWithReplace #-}+  runWithReplace a0 a' = do+    initialEnv <- HydrationDomBuilderT ask+    let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv+    (hydrateStart, before, beforeKey) <- skipToReplaceStart+    let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv+    haveEverBeenReady <- liftIO $ newIORef False+    currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM+    let myCommitAction = do+          liftIO (readIORef haveEverBeenReady) >>= \case+            True -> return ()+            False -> do+              liftIO $ writeIORef haveEverBeenReady True+              old <- liftIO $ readIORef parentUnreadyChildren+              let new = pred old+              liftIO $ writeIORef parentUnreadyChildren $! new+              when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv+    -- We draw 'after' in this roundabout way to avoid using MonadFix+    doc <- askDocument+    parent <- getParent+    (hydrateEnd, after) <- skipToReplaceEnd beforeKey+    let drawInitialChild = do+          h <- liftIO $ readIORef hydrating+          p' <- case h of+            HydrationMode_Hydrating -> pure parent+            HydrationMode_Immediate -> toNode <$> createDocumentFragment doc+          unreadyChildren <- liftIO $ newIORef 0+          let a0' = case h of+                HydrationMode_Hydrating -> a0+                HydrationMode_Immediate -> do+                  a <- a0+                  insertBefore p' =<< liftIO (readIORef after)+                  pure a+          delayed <- case h of+            HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()+            HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv+          result <- runReaderT (unHydrationDomBuilderT a0') initialEnv+            { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+            , _hydrationDomBuilderEnv_commitAction = myCommitAction+            , _hydrationDomBuilderEnv_parent = Left p'+            , _hydrationDomBuilderEnv_delayed = delayed+            }+          dom <- case h of+            HydrationMode_Hydrating -> liftIO $ readIORef delayed+            HydrationMode_Immediate -> pure $ pure ()+          liftIO $ readIORef unreadyChildren >>= \case+            0 -> writeIORef haveEverBeenReady True+            _ -> modifyIORef' parentUnreadyChildren succ+          return (dom, result)+    a'' <- numberOccurrences a'+    ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do+      h <- liftIO $ readIORef hydrating+      p' <- case h of+        HydrationMode_Hydrating -> pure parent+        HydrationMode_Immediate -> toNode <$> createDocumentFragment doc+      unreadyChildren <- liftIO $ newIORef 0+      let commitAction = do+            c <- liftIO $ readIORef currentCohort+            when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this+              !before' <- liftIO $ readIORef before+              !after' <- liftIO $ readIORef after+              deleteBetweenExclusive before' after'+              insertBefore p' after'+              liftIO $ writeIORef currentCohort cohortId+              myCommitAction+      delayed <- case h of+        HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()+        HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv+      result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv+            { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+            , _hydrationDomBuilderEnv_commitAction = case h of+              HydrationMode_Hydrating -> myCommitAction+              HydrationMode_Immediate -> commitAction+            , _hydrationDomBuilderEnv_parent = Left p'+            , _hydrationDomBuilderEnv_delayed = delayed+            }+      dom <- case h of+        HydrationMode_Hydrating -> liftIO $ readIORef delayed+        HydrationMode_Immediate -> pure $ pure ()+      uc <- liftIO $ readIORef unreadyChildren+      let commitActionToRunNow = if uc == 0+            then Just $ commitAction+            else Nothing -- A child will run it when unreadyChildren is decremented to 0+          actions = case h of+            HydrationMode_Hydrating -> Left dom+            HydrationMode_Immediate -> Right commitActionToRunNow+      return (actions, result)+    let (hydrate', commitAction) = fanEither $ fmap fst child'+    addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do+      hydrateStart+      join $ sample contents+      hydrateEnd+    requestDomAction_ $ fmapMaybe id commitAction+    return (result0, snd <$> child')++  {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}+  traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'+  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'+  {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}+  traverseDMapWithKeyWithAdjustWithMove = do+    let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do+          let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState (Some k)))) a)+              new k = PatchDMapWithMove.nodeInfoMapFromM $ \case+                PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete+                PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do+                  readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case+                    ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete+                    ChildReadyState_Unready _ -> do+                      writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This 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+                return $ Constant ()+          p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p+          _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old+          return $ applyAlways p' old+    hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do+      let p = unPatchDMapWithMove p_+      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+            case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of+              False -> do+                mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder+                return $ Constant Nothing+              True -> do+                Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder+      collected <- DMap.traverseWithKey collectIfMoved p+      let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore+          weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))+          weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_+          filtered :: PatchMapWithMove (Some k) DOM.Text+          filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of+            PatchMapWithMove.From_Insert (Left _hydration) -> Nothing+            PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate+            PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete+            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+            case PatchDMapWithMove._nodeInfo_from e of+              PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of+                Left _ -> pure ()+                Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder+              PatchDMapWithMove.From_Delete -> do+                return ()+              PatchDMapWithMove.From_Move fromKey -> do+                Just (Constant mdf) <- return $ DMap.lookup fromKey collected+                mapM_ (`insertBefore` nextPlaceholder) mdf+            return $ Constant ()+      mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time+      liftIO $ writeIORef placeholders $! phsAfter++{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}+traverseDMapWithKeyWithAdjust'+  :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)+  => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))+  -> DMap k v+  -> Event t (PatchDMap k v)+  -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))+traverseDMapWithKeyWithAdjust' = do+  let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do+        let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)+            new k (ComposeMaybe m) = ComposeMaybe <$> case m of+              Nothing -> return Nothing+              Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing+              Just (Compose (TraverseChild (Right immediate) _)) -> do+                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+                    return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)+            delete _ (Constant sRef) = do+              writeIORef sRef $ ChildReadyState_Unready Nothing+              return $ Constant ()+        p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p+        _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old+        return $ applyAlways p' old+  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+      -- Delete old node+      forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do+        thisPlaceholder `deleteUpTo` nextPlaceholder+      -- Insert new node+      forM_ mv $ \(Compose (TraverseChild e _)) -> case e of+        Left _hydration -> pure ()+        Right immediate -> do+          _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder+    let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))+        weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch+        filtered :: PatchMap (Some k) DOM.Text+        filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case+          Nothing -> Just Nothing -- deletion+          Just (Left _) -> Nothing+          Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate+    liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs++{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}+traverseIntMapWithKeyWithAdjust'+  :: forall s t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)+  => (IntMap.Key -> v -> HydrationDomBuilderT s t m v')+  -> IntMap v+  -> Event t (PatchIntMap v)+  -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))+traverseIntMapWithKeyWithAdjust' = do+  let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do+        let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))+            new k m = case m of+              Nothing -> return Nothing+              Just (TraverseChild (Left _hydration) _) -> pure Nothing+              Just (TraverseChild (Right immediate) _) -> do+                let sRef = _traverseChildImmediate_childReadyState immediate+                readIORef sRef >>= \case+                  ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready+                  ChildReadyState_Unready _ -> do+                    writeIORef sRef $ ChildReadyState_Unready $ Just k+                    return $ Just sRef+            delete _ sRef = do+              writeIORef sRef $ ChildReadyState_Unready Nothing+              return ()+        p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner+        _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old+        return $ applyAlways p' old+  hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do+    phs <- liftIO $ readIORef placeholders+    forM_ (IntMap.toList p) $ \(k, mv) -> do+      let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs+      -- Delete old node+      forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder+      -- Insert new node+      forM_ mv $ \(TraverseChild e _) -> case e of+        Left _hydration -> pure ()+        Right immediate -> do+          _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder+    let filtered :: PatchIntMap DOM.Text+        filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case+          Nothing -> Just Nothing -- deletion+          Just tc+            | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate+            | otherwise -> Nothing+    liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs++{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'+  :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')+  -> IntMap v+  -> Event DomTimeline (PatchIntMap v)+  -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))+  #-}++{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'+  :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')+  -> IntMap v+  -> Event DomTimeline (PatchIntMap v)+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))+  #-}++data ChildReadyState a+   = ChildReadyState_Ready+   | ChildReadyState_Unready !(Maybe a)+   deriving (Show, Read, Eq, Ord)++insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()+insertAfterPreviousNode node = do+  parent <- askParent+  nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode+  Node.insertBefore_ parent node nextNode+  setPreviousNode $ Just $ toNode node++{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}+hoistTraverseWithKeyWithAdjust+  ::+  ( Adjustable t m+  , MonadHold t m+  , DMap.GCompare k+  , MonadIO m+  , MonadJSM m+  , PrimMonad m+  , MonadFix m+  , Patch (p k v)+  , Patch (p k (Constant Int))+  , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)+  , Patch (p k (Compose (TraverseChild t m (Some k)) v'))+  , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')+  , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))+  , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document+  )+  => (forall vv vv'.+         (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))+      -> DMap k vv+      -> Event t (p k vv)+      -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))+  -- ^ The base monad's traversal+  -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')+  -- ^ A way of mapping over the patch type+  -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))+  -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state+  -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())+  -- ^ Apply a patch to the DOM+  -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))+  -> DMap k v+  -> Event t (p k v)+  -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do+  doc <- askDocument+  initialEnv <- HydrationDomBuilderT ask+  let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv+  pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty+  haveEverBeenReady <- liftIO $ newIORef False+  placeholders <- liftIO $ newIORef Map.empty+  lastPlaceholder <- createTextNode doc ("" :: Text)+  let applyDomUpdate p = do+        applyDomUpdate_ placeholders lastPlaceholder p+        markSelfReady+        liftIO $ writeIORef pendingChange $! mempty+      markSelfReady = do+        liftIO (readIORef haveEverBeenReady) >>= \case+          True -> return ()+          False -> do+            liftIO $ writeIORef haveEverBeenReady True+            old <- liftIO $ readIORef parentUnreadyChildren+            let new = pred old+            liftIO $ writeIORef parentUnreadyChildren $! new+            when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv+      markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()+      markChildReady childReadyState = do+        liftIO (readIORef childReadyState) >>= \case+          ChildReadyState_Ready -> return ()+          ChildReadyState_Unready countedAt -> do+            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+                (oldUnready, p) <- liftIO $ readIORef pendingChange+                when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null+                  let newUnready = DMap.delete k oldUnready+                  liftIO $ writeIORef pendingChange (newUnready, p)+                  when (DMap.null newUnready) $ do+                    applyDomUpdate p+  (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))+    <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'+  let processChild k (Compose (TraverseChild e _)) = case e of+        Left _ -> pure $ ComposeMaybe Nothing+        Right immediate -> ComposeMaybe <$> do+          readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case+            ChildReadyState_Ready -> return Nothing+            ChildReadyState_Unready _ -> do+              writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k+              return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)+  initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0+  liftIO $ if DMap.null initialUnready+    then writeIORef haveEverBeenReady True+    else do+      modifyIORef' parentUnreadyChildren succ+      writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time+  getHydrationMode >>= \case+    HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do+      dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children+      phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm+      liftIO $ writeIORef placeholders $! phs+      insertAfterPreviousNode lastPlaceholder+    HydrationMode_Immediate -> do+      let activate i = do+            append $ toNode $ _traverseChildImmediate_fragment i+            pure $ _traverseChildImmediate_placeholder i+      phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0+      liftIO $ writeIORef placeholders $! phs+      append $ toNode lastPlaceholder+  requestDomAction_ $ ffor children' $ \p -> do+    (oldUnready, oldP) <- liftIO $ readIORef pendingChange+    newUnready <- liftIO $ updateChildUnreadiness p oldUnready+    let !newP = p <> oldP+    liftIO $ writeIORef pendingChange (newUnready, newP)+    when (DMap.null newUnready) $ do+      applyDomUpdate newP+  let result0 = DMap.map (_traverseChild_result . getCompose) children0+      result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose+  return (result0, result')++{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}+hoistTraverseIntMapWithKeyWithAdjust ::+  ( Adjustable t m+  , MonadHold t m+  , MonadJSM m+  , MonadFix m+  , PrimMonad m+  , Monoid (p (TraverseChild t m Int v'))+  , Functor p+  , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())+  , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')+  , Patch (p (HydrationRunnerT t m ()))+  , Patch (p (TraverseChild t m Int v'))+  , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document+  )+  => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))+    -> IntMap v+    -> Event t (p v)+    -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))+  -- ^ The base monad's traversal+  -> (p (TraverseChild t m Int v')+    -> IntMap (IORef (ChildReadyState Int))+    -> IO (IntMap (IORef (ChildReadyState Int))))+  -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state+  -> (IORef (IntMap DOM.Text)+    -> DOM.Text+    -> p (TraverseChild t m Int v')+    -> JSM ())+  -- ^ Apply a patch to the DOM+  -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')+  -> IntMap v+  -> Event t (p v)+  -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do+  doc <- askDocument+  initialEnv <- HydrationDomBuilderT ask+  let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv+  pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty+  haveEverBeenReady <- liftIO $ newIORef False+  placeholders <- liftIO $ newIORef IntMap.empty+  lastPlaceholder <- createTextNode doc ("" :: Text)+  let applyDomUpdate p = do+        applyDomUpdate_ placeholders lastPlaceholder p+        markSelfReady+        liftIO $ writeIORef pendingChange $! mempty+      markSelfReady = do+        liftIO (readIORef haveEverBeenReady) >>= \case+          True -> return ()+          False -> do+            liftIO $ writeIORef haveEverBeenReady True+            old <- liftIO $ readIORef parentUnreadyChildren+            let new = pred old+            liftIO $ writeIORef parentUnreadyChildren $! new+            when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv+      markChildReady :: IORef (ChildReadyState Int) -> JSM ()+      markChildReady childReadyState = do+        liftIO (readIORef childReadyState) >>= \case+          ChildReadyState_Ready -> return ()+          ChildReadyState_Unready countedAt -> do+            liftIO $ writeIORef childReadyState ChildReadyState_Ready+            case countedAt of+              Nothing -> return ()+              Just 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 $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null+                  let newUnready = IntMap.delete k oldUnready+                  liftIO $ writeIORef pendingChange (newUnready, p)+                  when (IntMap.null newUnready) $ do+                    applyDomUpdate p+  (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))+    <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'+  let processChild k (TraverseChild e _) = case e of+        Left _ -> pure Nothing+        Right immediate -> do+          readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case+            ChildReadyState_Ready -> return Nothing+            ChildReadyState_Unready _ -> do+              writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k+              return $ Just (_traverseChildImmediate_childReadyState immediate)+  initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0+  liftIO $ if IntMap.null initialUnready+    then writeIORef haveEverBeenReady True+    else do+      modifyIORef' parentUnreadyChildren succ+      writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time+  getHydrationMode >>= \case+    HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do+      dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children+      phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm+      liftIO $ writeIORef placeholders $! phs+      insertAfterPreviousNode lastPlaceholder+    HydrationMode_Immediate -> do+      let activate i = do+            append $ toNode $ _traverseChildImmediate_fragment i+            pure $ _traverseChildImmediate_placeholder i+      phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0+      liftIO $ writeIORef placeholders $! phs+      append $ toNode lastPlaceholder+  requestDomAction_ $ ffor children' $ \p -> do+    (oldUnready, oldP) <- liftIO $ readIORef pendingChange+    newUnready <- liftIO $ updateChildUnreadiness p oldUnready+    let !newP = p <> oldP+    liftIO $ writeIORef pendingChange (newUnready, newP)+    when (IntMap.null newUnready) $ do+      applyDomUpdate newP+  let result0 = IntMap.map _traverseChild_result children0+      result' = ffor children' $ fmap $ _traverseChild_result+  return (result0, result')++{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust+  :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))+    -> IntMap v+    -> Event DomTimeline (PatchIntMap v)+    -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))+  -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')+    -> IntMap (IORef (ChildReadyState Int))+    -> IO (IntMap (IORef (ChildReadyState Int))))+  -> (IORef (IntMap DOM.Text)+    -> DOM.Text+    -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')+    -> JSM ())+  -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')+  -> IntMap v+  -> Event DomTimeline (PatchIntMap v)+  -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))+  #-}++{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust+  :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))+    -> IntMap v+    -> Event DomTimeline (PatchIntMap v)+    -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))+  -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')+    -> IntMap (IORef (ChildReadyState Int))+    -> IO (IntMap (IORef (ChildReadyState Int))))+  -> (IORef (IntMap DOM.Text)+    -> DOM.Text+    -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')+    -> JSM ())+  -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')+  -> IntMap v+  -> Event DomTimeline (PatchIntMap v)+  -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))+  #-}++data TraverseChildImmediate k = TraverseChildImmediate+  { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment+  -- ^ Child is appended to this fragment+  , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text+  -- ^ Placeholder reference+  , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))+  }++newtype TraverseChildHydration t m = TraverseChildHydration+  { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text+  -- ^ Action to run at switchover, returns the placeholder+  }++data TraverseChild t m k a = TraverseChild+  { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))+  , _traverseChild_result :: !a+  } deriving Functor++{-# INLINABLE drawChildUpdate #-}+drawChildUpdate :: (MonadJSM m, Reflex t)+  => HydrationDomBuilderEnv t m+  -> (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+  -> HydrationDomBuilderT s t m (f a)+  -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)+drawChildUpdate initialEnv markReady child = do+  let doc = _hydrationDomBuilderEnv_document initialEnv+  unreadyChildren <- liftIO $ newIORef 0+  liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case+    HydrationMode_Hydrating -> do+      childDelayedRef <- liftIO $ newIORef $ pure ()+      result <- runReaderT (unHydrationDomBuilderT child) initialEnv+        { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+        , _hydrationDomBuilderEnv_delayed = childDelayedRef+        }+      childDelayed <- liftIO $ readIORef childDelayedRef+      return $ Compose $ TraverseChild+        { _traverseChild_result = result+        , _traverseChild_mode = Left TraverseChildHydration+          { _traverseChildHydration_delayed = do+            placeholder <- createTextNode doc ("" :: Text)+            insertAfterPreviousNode placeholder+            childDelayed+            pure placeholder+          }+        }+    HydrationMode_Immediate -> do+      childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing+      df <- createDocumentFragment doc+      placeholder <- createTextNode doc ("" :: Text)+      Node.appendChild_ df placeholder+      result <- runReaderT (unHydrationDomBuilderT child) initialEnv+        { _hydrationDomBuilderEnv_parent = Left $ toNode df+        , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+        , _hydrationDomBuilderEnv_commitAction = markReady childReadyState+        }+      u <- liftIO $ readIORef unreadyChildren+      when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready+      return $ Compose $ TraverseChild+        { _traverseChild_result = result+        , _traverseChild_mode = Right TraverseChildImmediate+          { _traverseChildImmediate_fragment = df+          , _traverseChildImmediate_placeholder = placeholder+          , _traverseChildImmediate_childReadyState = childReadyState+          }+        }++{-# SPECIALIZE drawChildUpdate+  :: HydrationDomBuilderEnv DomTimeline HydrationM+  -> (IORef (ChildReadyState Int) -> JSM ())+  -> HydrationDomBuilderT s DomTimeline HydrationM (Identity a)+  -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM Int) Identity a)+  #-}++{-# SPECIALIZE drawChildUpdate+  :: HydrationDomBuilderEnv DomTimeline HydrationM+  -> (IORef (ChildReadyState (Some k)) -> JSM ())+  -> HydrationDomBuilderT s DomTimeline HydrationM (f a)+  -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM (Some k)) f a)+  #-}++{-# INLINABLE drawChildUpdateInt #-}+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)+  => HydrationDomBuilderEnv t m+  -> (IORef (ChildReadyState k) -> JSM ())+  -> HydrationDomBuilderT s t m v+  -> DomRenderHookT t m (TraverseChild t m k v)+drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)++{-# SPECIALIZE drawChildUpdateInt+  :: HydrationDomBuilderEnv DomTimeline HydrationM+  -> (IORef (ChildReadyState k) -> JSM ())+  -> HydrationDomBuilderT s DomTimeline HydrationM v+  -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM k v)+  #-}++{-# INLINE mkHasFocus #-}+mkHasFocus+  :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))+  => Element er d t -> m (Dynamic t Bool)+mkHasFocus e = do+  doc <- askDocument+  initialFocus <- Node.isSameNode (toNode $ _element_raw e) . fmap toNode =<< Document.getActiveElement doc+  holdDyn initialFocus $ leftmost+    [ False <$ Reflex.select (_element_events e) (WrapArg Blur)+    , True <$ Reflex.select (_element_events e) (WrapArg Focus)+    ]++insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()+insertBefore new existing = do+  p <- getParentNodeUnchecked existing+  Node.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly++type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace++instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where+  type Performable (HydrationDomBuilderT s t m) = Performable m+  {-# INLINABLE performEvent_ #-}+  performEvent_ e = lift $ performEvent_ e+  {-# INLINABLE performEvent #-}+  performEvent e = lift $ performEvent e++instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where+  {-# INLINABLE getPostBuild #-}+  getPostBuild = lift getPostBuild++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where+  {-# INLINABLE newEventWithTrigger #-}+  newEventWithTrigger = lift . newEventWithTrigger+  {-# INLINABLE newFanEventWithTrigger #-}+  newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT s t m) where+  {-# INLINABLE newTriggerEvent #-}+  newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent+  {-# INLINABLE newTriggerEventWithOnComplete #-}+  newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete+  {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}+  newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f++instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where+  {-# INLINABLE newTriggerEvent #-}+  newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent+  {-# INLINABLE newTriggerEventWithOnComplete #-}+  newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete+  {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}+  newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f++instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where+  type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m+  askJSContext = lift askJSContext++instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where+  type Ref (HydrationDomBuilderT s t m) = Ref m+  {-# INLINABLE newRef #-}+  newRef = lift . newRef+  {-# INLINABLE readRef #-}+  readRef = lift . readRef+  {-# INLINABLE writeRef #-}+  writeRef r = lift . writeRef r++instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where+  {-# INLINABLE atomicModifyRef #-}+  atomicModifyRef r = lift . atomicModifyRef r++instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where+  type JSX (HydrationDomBuilderT s t m) = JSX m+  liftJS = lift . liftJS++type family EventType en where+  EventType 'AbortTag = UIEvent+  EventType 'BlurTag = FocusEvent+  EventType 'ChangeTag = DOM.Event+  EventType 'ClickTag = MouseEvent+  EventType 'ContextmenuTag = MouseEvent+  EventType 'DblclickTag = MouseEvent+  EventType 'DragTag = MouseEvent+  EventType 'DragendTag = MouseEvent+  EventType 'DragenterTag = MouseEvent+  EventType 'DragleaveTag = MouseEvent+  EventType 'DragoverTag = MouseEvent+  EventType 'DragstartTag = MouseEvent+  EventType 'DropTag = MouseEvent+  EventType 'ErrorTag = UIEvent+  EventType 'FocusTag = FocusEvent+  EventType 'InputTag = DOM.Event+  EventType 'InvalidTag = DOM.Event+  EventType 'KeydownTag = KeyboardEvent+  EventType 'KeypressTag = KeyboardEvent+  EventType 'KeyupTag = KeyboardEvent+  EventType 'LoadTag = UIEvent+  EventType 'MousedownTag = MouseEvent+  EventType 'MouseenterTag = MouseEvent+  EventType 'MouseleaveTag = MouseEvent+  EventType 'MousemoveTag = MouseEvent+  EventType 'MouseoutTag = MouseEvent+  EventType 'MouseoverTag = MouseEvent+  EventType 'MouseupTag = MouseEvent+  EventType 'MousewheelTag = MouseEvent+  EventType 'ScrollTag = UIEvent+  EventType 'SelectTag = UIEvent+  EventType 'SubmitTag = DOM.Event+  EventType 'WheelTag = WheelEvent+  EventType 'BeforecutTag = ClipboardEvent+  EventType 'CutTag = ClipboardEvent+  EventType 'BeforecopyTag = ClipboardEvent+  EventType 'CopyTag = ClipboardEvent+  EventType 'BeforepasteTag = ClipboardEvent+  EventType 'PasteTag = ClipboardEvent+  EventType 'ResetTag = DOM.Event+  EventType 'SearchTag = DOM.Event+  EventType 'SelectstartTag = DOM.Event+  EventType 'TouchstartTag = TouchEvent+  EventType 'TouchmoveTag = TouchEvent+  EventType 'TouchendTag = TouchEvent+  EventType 'TouchcancelTag = TouchEvent++{-# INLINABLE defaultDomEventHandler #-}+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))+defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of+  Click -> return ()+  Dblclick -> getMouseEventCoords+  Keypress -> getKeyEvent+  Scroll -> fromIntegral <$> getScrollTop e+  Keydown -> getKeyEvent+  Keyup -> getKeyEvent+  Mousemove -> getMouseEventCoords+  Mouseup -> getMouseEventCoords+  Mousedown -> getMouseEventCoords+  Mouseenter -> return ()+  Mouseleave -> return ()+  Focus -> return ()+  Blur -> return ()+  Change -> return ()+  Drag -> return ()+  Dragend -> return ()+  Dragenter -> return ()+  Dragleave -> return ()+  Dragover -> return ()+  Dragstart -> return ()+  Drop -> return ()+  Abort -> return ()+  Contextmenu -> return ()+  Error -> return ()+  Input -> return ()+  Invalid -> return ()+  Load -> return ()+  Mouseout -> return ()+  Mouseover -> return ()+  Select -> return ()+  Submit -> return ()+  Beforecut -> return ()+  Cut -> return ()+  Beforecopy -> return ()+  Copy -> return ()+  Beforepaste -> return ()+  Paste -> return ()+  Reset -> return ()+  Search -> return ()+  Selectstart -> return ()+  Touchstart -> getTouchEvent+  Touchmove -> getTouchEvent+  Touchend -> getTouchEvent+  Touchcancel -> getTouchEvent+  Mousewheel -> return ()+  Wheel -> return ()++{-# INLINABLE defaultDomWindowEventHandler #-}+defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))+defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of+  Click -> return ()+  Dblclick -> getMouseEventCoords+  Keypress -> getKeyEvent+  Scroll -> Window.getScrollY w+  Keydown -> getKeyEvent+  Keyup -> getKeyEvent+  Mousemove -> getMouseEventCoords+  Mouseup -> getMouseEventCoords+  Mousedown -> getMouseEventCoords+  Mouseenter -> return ()+  Mouseleave -> return ()+  Focus -> return ()+  Blur -> return ()+  Change -> return ()+  Drag -> return ()+  Dragend -> return ()+  Dragenter -> return ()+  Dragleave -> return ()+  Dragover -> return ()+  Dragstart -> return ()+  Drop -> return ()+  Abort -> return ()+  Contextmenu -> return ()+  Error -> return ()+  Input -> return ()+  Invalid -> return ()+  Load -> return ()+  Mouseout -> return ()+  Mouseover -> return ()+  Select -> return ()+  Submit -> return ()+  Beforecut -> return ()+  Cut -> return ()+  Beforecopy -> return ()+  Copy -> return ()+  Beforepaste -> return ()+  Paste -> return ()+  Reset -> return ()+  Search -> return ()+  Selectstart -> return ()+  Touchstart -> getTouchEvent+  Touchmove -> getTouchEvent+  Touchend -> getTouchEvent+  Touchcancel -> getTouchEvent+  Mousewheel -> return ()+  Wheel -> return ()++{-# INLINABLE withIsEvent #-}+withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r+withIsEvent en r = case en of+  Click -> r+  Dblclick -> r+  Keypress -> r+  Scroll -> r+  Keydown -> r+  Keyup -> r+  Mousemove -> r+  Mouseup -> r+  Mousedown -> r+  Mouseenter -> r+  Mouseleave -> r+  Focus -> r+  Blur -> r+  Change -> r+  Drag -> r+  Dragend -> r+  Dragenter -> r+  Dragleave -> r+  Dragover -> r+  Dragstart -> r+  Drop -> r+  Abort -> r+  Contextmenu -> r+  Error -> r+  Input -> r+  Invalid -> r+  Load -> r+  Mouseout -> r+  Mouseover -> r+  Select -> r+  Submit -> r+  Beforecut -> r+  Cut -> r+  Beforecopy -> r+  Copy -> r+  Beforepaste -> r+  Paste -> r+  Reset -> r+  Search -> r+  Selectstart -> r+  Touchstart -> r+  Touchmove -> r+  Touchend -> r+  Touchcancel -> r+  Mousewheel -> r+  Wheel -> r++showEventName :: EventName en -> String+showEventName en = case en of+  Abort -> "Abort"+  Blur -> "Blur"+  Change -> "Change"+  Click -> "Click"+  Contextmenu -> "Contextmenu"+  Dblclick -> "Dblclick"+  Drag -> "Drag"+  Dragend -> "Dragend"+  Dragenter -> "Dragenter"+  Dragleave -> "Dragleave"+  Dragover -> "Dragover"+  Dragstart -> "Dragstart"+  Drop -> "Drop"+  Error -> "Error"+  Focus -> "Focus"+  Input -> "Input"+  Invalid -> "Invalid"+  Keydown -> "Keydown"+  Keypress -> "Keypress"+  Keyup -> "Keyup"+  Load -> "Load"+  Mousedown -> "Mousedown"+  Mouseenter -> "Mouseenter"+  Mouseleave -> "Mouseleave"+  Mousemove -> "Mousemove"+  Mouseout -> "Mouseout"+  Mouseover -> "Mouseover"+  Mouseup -> "Mouseup"+  Mousewheel -> "Mousewheel"+  Scroll -> "Scroll"+  Select -> "Select"+  Submit -> "Submit"+  Wheel -> "Wheel"+  Beforecut -> "Beforecut"+  Cut -> "Cut"+  Beforecopy -> "Beforecopy"+  Copy -> "Copy"+  Beforepaste -> "Beforepaste"+  Paste -> "Paste"+  Reset -> "Reset"+  Search -> "Search"+  Selectstart -> "Selectstart"+  Touchstart -> "Touchstart"+  Touchmove -> "Touchmove"+  Touchend -> "Touchend"+  Touchcancel -> "Touchcancel"++--TODO: Get rid of this hack+-- ElementEventTarget is here to allow us to treat SVG and HTML elements as the same thing; without it, we'll break any existing SVG code.+newtype ElementEventTarget = ElementEventTarget DOM.Element deriving (DOM.IsGObject, DOM.ToJSVal, DOM.IsSlotable, DOM.IsParentNode, DOM.IsNonDocumentTypeChildNode, DOM.IsChildNode, DOM.IsAnimatable, IsNode, IsElement)+instance DOM.FromJSVal ElementEventTarget where+  fromJSVal = fmap (fmap ElementEventTarget) . DOM.fromJSVal+instance DOM.IsEventTarget ElementEventTarget+instance DOM.IsGlobalEventHandlers ElementEventTarget+instance DOM.IsDocumentAndElementEventHandlers ElementEventTarget++{-# INLINABLE elementOnEventName #-}+elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())+elementOnEventName en e_ = let e = ElementEventTarget (DOM.toElement e_) in case en of+  Abort -> on e Events.abort+  Blur -> on e Events.blur+  Change -> on e Events.change+  Click -> on e Events.click+  Contextmenu -> on e Events.contextMenu+  Dblclick -> on e Events.dblClick+  Drag -> on e Events.drag+  Dragend -> on e Events.dragEnd+  Dragenter -> on e Events.dragEnter+  Dragleave -> on e Events.dragLeave+  Dragover -> on e Events.dragOver+  Dragstart -> on e Events.dragStart+  Drop -> on e Events.drop+  Error -> on e Events.error+  Focus -> on e Events.focus+  Input -> on e Events.input+  Invalid -> on e Events.invalid+  Keydown -> on e Events.keyDown+  Keypress -> on e Events.keyPress+  Keyup -> on e Events.keyUp+  Load -> on e Events.load+  Mousedown -> on e Events.mouseDown+  Mouseenter -> on e Events.mouseEnter+  Mouseleave -> on e Events.mouseLeave+  Mousemove -> on e Events.mouseMove+  Mouseout -> on e Events.mouseOut+  Mouseover -> on e Events.mouseOver+  Mouseup -> on e Events.mouseUp+  Mousewheel -> on e Events.mouseWheel+  Scroll -> on e Events.scroll+  Select -> on e Events.select+  Submit -> on e Events.submit+  Wheel -> on e Events.wheel+  Beforecut -> on e Events.beforeCut+  Cut -> on e Events.cut+  Beforecopy -> on e Events.beforeCopy+  Copy -> on e Events.copy+  Beforepaste -> on e Events.beforePaste+  Paste -> on e Events.paste+  Reset -> on e Events.reset+  Search -> on e Events.search+  Selectstart -> on e Element.selectStart+  Touchstart -> on e Events.touchStart+  Touchmove -> on e Events.touchMove+  Touchend -> on e Events.touchEnd+  Touchcancel -> on e Events.touchCancel++{-# INLINABLE windowOnEventName #-}+windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> JSM (JSM ())+windowOnEventName en e = case en of+  Abort -> on e Events.abort+  Blur -> on e Events.blur+  Change -> on e Events.change+  Click -> on e Events.click+  Contextmenu -> on e Events.contextMenu+  Dblclick -> on e Events.dblClick+  Drag -> on e Events.drag+  Dragend -> on e Events.dragEnd+  Dragenter -> on e Events.dragEnter+  Dragleave -> on e Events.dragLeave+  Dragover -> on e Events.dragOver+  Dragstart -> on e Events.dragStart+  Drop -> on e Events.drop+  Error -> on e Events.error+  Focus -> on e Events.focus+  Input -> on e Events.input+  Invalid -> on e Events.invalid+  Keydown -> on e Events.keyDown+  Keypress -> on e Events.keyPress+  Keyup -> on e Events.keyUp+  Load -> on e Events.load+  Mousedown -> on e Events.mouseDown+  Mouseenter -> on e Events.mouseEnter+  Mouseleave -> on e Events.mouseLeave+  Mousemove -> on e Events.mouseMove+  Mouseout -> on e Events.mouseOut+  Mouseover -> on e Events.mouseOver+  Mouseup -> on e Events.mouseUp+  Mousewheel -> on e Events.mouseWheel+  Scroll -> on e Events.scroll+  Select -> on e Events.select+  Submit -> on e Events.submit+  Wheel -> on e Events.wheel+  Beforecut -> const $ return $ return () --TODO+  Cut -> const $ return $ return () --TODO+  Beforecopy -> const $ return $ return () --TODO+  Copy -> const $ return $ return () --TODO+  Beforepaste -> const $ return $ return () --TODO+  Paste -> const $ return $ return () --TODO+  Reset -> on e Events.reset+  Search -> on e Events.search+  Selectstart -> const $ return $ return () --TODO+  Touchstart -> on e Events.touchStart+  Touchmove -> on e Events.touchMove+  Touchend -> on e Events.touchEnd+  Touchcancel -> on e Events.touchCancel++{-# INLINABLE wrapDomEvent #-}+wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)+wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue++{-# INLINABLE subscribeDomEvent #-}+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))+                  -> EventM e event (Maybe a)+                  -> Chan [DSum (EventTriggerRef t) TriggerInvocation]+                  -> EventTrigger t a+                  -> JSM (JSM ())+subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do+  mv <- getValue+  forM_ mv $ \v -> liftIO $ do+    --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+    etr <- newIORef $ Just et+    writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]++{-# INLINABLE wrapDomEventMaybe #-}+wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)+                  => e+                  -> (e -> EventM e event () -> JSM (JSM ()))+                  -> EventM e event (Maybe a)+                  -> m (Event t a)+wrapDomEventMaybe el elementOnevent getValue = do+  ctx <- askJSM+  newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do+    mv <- getValue+    forM_ mv $ \v -> liftIO $ trigger v $ return ())++{-# INLINABLE wrapDomEventsMaybe #-}+wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)+                   => e+                   -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))+                   -> (forall en. EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ()))+                   -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))+wrapDomEventsMaybe target handlers onEventName = do+  ctx <- askJSM+  eventChan <- askEvents+  e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en+    (((`runJSM` ctx) <$>) . (`runJSM` ctx) . subscribeDomEvent (onEventName en target) (handlers en) eventChan)+  return $! e++{-# INLINABLE getKeyEvent #-}+getKeyEvent :: EventM e KeyboardEvent Word+getKeyEvent = do+  e <- event+  which <- KeyboardEvent.getWhich e+  if which /= 0 then return which else do+    charCode <- getCharCode e+    if charCode /= 0 then return charCode else+      getKeyCode e++{-# INLINABLE getMouseEventCoords #-}+getMouseEventCoords :: EventM e MouseEvent (Int, Int)+getMouseEventCoords = do+  e <- event+  bisequence (getClientX e, getClientY e)++{-# INLINABLE getTouchEvent #-}+getTouchEvent :: EventM e TouchEvent TouchEventResult+getTouchEvent = do+  let touchResults ts = do+          n <- TouchList.getLength ts+          forM (takeWhile (< n) [0..]) $ \ix -> do+            t <- TouchList.item ts ix+            identifier <- Touch.getIdentifier t+            screenX <- Touch.getScreenX t+            screenY <- Touch.getScreenY t+            clientX <- Touch.getClientX t+            clientY <- Touch.getClientY t+            pageX <- Touch.getPageX t+            pageY <- Touch.getPageY t+            return TouchResult+              { _touchResult_identifier = identifier+              , _touchResult_screenX = screenX+              , _touchResult_screenY = screenY+              , _touchResult_clientX = clientX+              , _touchResult_clientY = clientY+              , _touchResult_pageX = pageX+              , _touchResult_pageY = pageY+              }+  e <- event+  altKey <- TouchEvent.getAltKey e+  ctrlKey <- TouchEvent.getCtrlKey e+  shiftKey <- TouchEvent.getShiftKey e+  metaKey <- TouchEvent.getMetaKey e+  changedTouches <- touchResults =<< TouchEvent.getChangedTouches e+  targetTouches <- touchResults =<< TouchEvent.getTargetTouches e+  touches <- touchResults =<< TouchEvent.getTouches e+  return $ TouchEventResult+    { _touchEventResult_altKey = altKey+    , _touchEventResult_changedTouches = changedTouches+    , _touchEventResult_ctrlKey = ctrlKey+    , _touchEventResult_metaKey = metaKey+    , _touchEventResult_shiftKey = shiftKey+    , _touchEventResult_targetTouches = targetTouches+    , _touchEventResult_touches = touches+    }++instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where+  {-# INLINABLE sample #-}+  sample = lift . sample++instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where+  {-# INLINABLE hold #-}+  hold v0 v' = lift $ hold v0 v'+  {-# INLINABLE holdDyn #-}+  holdDyn v0 v' = lift $ holdDyn v0 v'+  {-# INLINABLE holdIncremental #-}+  holdIncremental v0 v' = lift $ holdIncremental v0 v'+  {-# INLINABLE buildDynamic #-}+  buildDynamic a0 = lift . buildDynamic a0+  {-# INLINABLE headE #-}+  headE = lift . headE++data WindowConfig t = WindowConfig -- No config options yet++instance Default (WindowConfig t) where+  def = WindowConfig++data Window t = Window+  { _window_events :: EventSelector t (WrapArg EventResult EventName)+  , _window_raw :: DOM.Window+  }++wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> HydrationDomBuilderT GhcjsDomSpace t m (Window t) wrapWindow wv _ = do   events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName   return $ Window

@@ -15,6 +15,7 @@ {-# LANGUAGE UndecidableInstances #-} module Reflex.Dom.Builder.Static where +import Data.IORef (IORef) import Blaze.ByteString.Builder.Html.Utf8 import Control.Lens hiding (element) import Control.Monad.Exception@@ -32,11 +33,14 @@ import Data.Dependent.Sum (DSum (..)) import Data.Functor.Compose import Data.Functor.Constant+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Map.Misc (applyMap)-import Data.Monoid+import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text)+import qualified Data.Text as T import Data.Text.Encoding import Data.Tuple import GHC.Generics@@ -49,7 +53,9 @@ import Reflex.PerformEvent.Base import Reflex.PerformEvent.Class import Reflex.PostBuild.Base+import Reflex.PostBuild.Class import Reflex.TriggerEvent.Class+import System.Random (randomRIO)  data StaticDomBuilderEnv t = StaticDomBuilderEnv   { _staticDomBuilderEnv_shouldEscape :: Bool@@ -77,6 +83,10 @@   (result, a') <- runStateT (runReaderT a e) []   return (result, mconcat $ reverse a') +instance PostBuild t m => PostBuild t (StaticDomBuilderT t m) where+  {-# INLINABLE getPostBuild #-}+  getPostBuild = lift getPostBuild+ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where   {-# INLINABLE newEventWithTrigger #-}   newEventWithTrigger = lift . newEventWithTrigger@@ -141,8 +151,8 @@   type EventSpec StaticDomSpace = StaticEventSpec   type RawDocument StaticDomSpace = ()   type RawTextNode StaticDomSpace = ()+  type RawCommentNode StaticDomSpace = ()   type RawElement StaticDomSpace = ()-  type RawFile StaticDomSpace = ()   type RawInputElement StaticDomSpace = ()   type RawTextAreaElement StaticDomSpace = ()   type RawSelectElement StaticDomSpace = ()@@ -151,21 +161,70 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilderT t m) where   askDocument = pure () -instance (Reflex t, Adjustable t m, MonadHold t m) => Adjustable t (StaticDomBuilderT t m) where+instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where   runWithReplace a0 a' = do     e <- StaticDomBuilderT ask+    key <- replaceStart     (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')     o <- hold (snd result0) $ fmapCheap snd result'     StaticDomBuilderT $ modify $ (:) $ join o+    replaceEnd key     return (fst result0, fmapCheap fst result')+  traverseIntMapWithKeyWithAdjust = hoistIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust   traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap   traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove +-- TODO remove this?+replaceStart :: (DomBuilder t m, MonadIO m) => m Text+replaceStart = do+  str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')+  let key = "-" <> T.pack str+  _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }+  pure key++replaceEnd :: DomBuilder t m => Text -> m ()+replaceEnd key = void $ commentNode $ def { _commentNodeConfig_initialContents = "replace-end" <> key }++hoistIntMapWithKeyWithAdjust :: forall t m p a b.+  ( Adjustable t m+  , MonadHold t m+  , Patch (p a)+  , Functor p+  , Patch (p (Behavior t Builder))+  , PatchTarget (p (Behavior t Builder)) ~ IntMap (Behavior t Builder)+  , Ref m ~ IORef, MonadIO m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m -- TODO remove+  )+  => (forall x. (IntMap.Key -> a -> m x)+      -> IntMap a+      -> Event t (p a)+      -> m (IntMap x, Event t (p x))+     ) -- ^ The base monad's traversal+  -> (IntMap.Key -> a -> StaticDomBuilderT t m b)+  -> IntMap a+  -> Event t (p a)+  -> StaticDomBuilderT t m (IntMap b, Event t (p b))+hoistIntMapWithKeyWithAdjust base f im0 im' = do+  e <- StaticDomBuilderT ask+  (children0, children') <- lift $ base (\k v -> runStaticDomBuilderT (f k v) e) im0 im'+  let result0 = IntMap.map fst children0+      result' = (fmap . fmap) fst children'+      outputs0 :: IntMap (Behavior t Builder)+      outputs0 = IntMap.map snd children0+      outputs' :: Event t (p (Behavior t Builder))+      outputs' = (fmap . fmap) snd children'+  outputs <- holdIncremental outputs0 outputs'+  StaticDomBuilderT $ modify $ (:) $ pull $ do+    os <- sample $ currentIncremental outputs+    fmap mconcat $ forM (IntMap.toList os) $ \(_, o) -> do+      sample o+  return (result0, result')+ hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.   ( Adjustable t m   , MonadHold t m   , PatchTarget (p k (Constant (Behavior t Builder))) ~ DMap k (Constant (Behavior t Builder))   , Patch (p k (Constant (Behavior t Builder)))+  , Ref m ~ IORef, MonadIO m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m -- TODO remove   )   => (forall vv vv'.          (forall a. k a -> vv a -> m (vv' a))@@ -210,6 +269,15 @@       Nothing -> return (pure (escape initialContents))       Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on     return $ TextNode ()+  {-# INLINABLE commentNode #-}+  commentNode (CommentNodeConfig initialContents mSetContents) = StaticDomBuilderT $ do+    --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5+    shouldEscape <- asks _staticDomBuilderEnv_shouldEscape+    let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8+    modify . (:) =<< (\c -> "<!--" <> c <> "-->") <$> case mSetContents of+      Nothing -> return (pure (escape initialContents))+      Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on+    return $ CommentNode ()   {-# INLINABLE element #-}   element elementTag cfg child = do     -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements@@ -220,7 +288,7 @@     StaticDomBuilderT $ do       let shouldEscape = elementTag `Set.notMember` noEscapeElements       (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing-      attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)+      attrs0 <- foldDyn applyMap (Map.insert "data-ssr" "" $ 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" ""

@@ -18,3 +18,4 @@ import Reflex.Dom.WebSocket as X import Reflex.Dom.Widget as X import Reflex.Dom.Xhr as X+import Reflex.Dom.Xhr.FormData as X

@@ -12,6 +12,7 @@   , getLocationProtocol   , getLocationUrl   , manageHistory+  , manageHistory'   , HistoryCommand (..)   , HistoryStateUpdate (..)   , HistoryItem (..)@@ -23,8 +24,11 @@  import Control.Lens ((^.)) import Control.Monad ((>=>))+import Control.Monad.Fix (MonadFix)+import Data.Align (align) import Data.Monoid import Data.Text (Text)+import Data.These (These(..)) import qualified GHCJS.DOM as DOM import qualified GHCJS.DOM.EventM as DOM import qualified GHCJS.DOM.Location as Location@@ -157,5 +161,40 @@     HistoryItem       <$> (SerializedScriptValue <$> PopStateEvent.getState e)       <*> getLocationUri location+  holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal]+--TODO: Handle title setting better++manageHistory'+  :: (MonadFix m, MonadJSM m, TriggerEvent t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m))+  => Event t ()+  -- ^ Don't do anything until this event has fired+  -> Event t HistoryCommand+  -> m (Dynamic t HistoryItem)+manageHistory' switchover runCmd = do+  window <- DOM.currentWindowUnchecked+  location <- Window.getLocation window+  history <- Window.getHistory window+  let getCurrentHistoryItem = HistoryItem+        <$> History.getState history+        <*> getLocationUri location+  item0 <- liftJSM getCurrentHistoryItem+  itemSetExternal' <- wrapDomEvent window (`DOM.on` DOM.popState) $ do+    e <- DOM.event+    HistoryItem+      <$> (SerializedScriptValue <$> PopStateEvent.getState e)+      <*> getLocationUri location+  let f :: (Bool, Maybe a) -> These a () -> (Maybe (Bool, Maybe a), Maybe a)+      f (switched, acc) = \case+        This change+          | switched -> (Nothing, Just change)+          | otherwise -> (Just (switched, Just change), Nothing)+        That () -> (Just (True, Nothing), acc)+        These change () -> (Just (True, Nothing), Just change)+  -- Accumulate the events before switchover+  (_, cmd') <- mapAccumMaybeB f (False, Nothing) $ align (leftmost [Left <$> runCmd, Right <$> itemSetExternal']) switchover+  let (itemSetInternal', itemSetExternal) = fanEither cmd'+  itemSetInternal <- performEvent $ ffor itemSetInternal' $ \cmd -> liftJSM $ do+    runHistoryCommand history cmd+    getCurrentHistoryItem   holdDyn item0 $ leftmost [itemSetInternal, itemSetExternal] --TODO: Handle title setting better

@@ -17,6 +17,8 @@  import Prelude hiding (concat, mapM, mapM_, sequence, sequence_) +import Reflex.Adjustable.Class+import Reflex.Class import Reflex.Dom.Builder.Immediate import Reflex.Dom.Class import Reflex.Host.Class@@ -24,8 +26,10 @@ import Reflex.PostBuild.Base import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost) import Reflex.TriggerEvent.Base--import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported+import Reflex.TriggerEvent.Class+#ifdef PROFILE_REFLEX+import Reflex.Profiled+#endif  import Control.Concurrent import Control.Lens@@ -34,6 +38,7 @@ import Control.Monad.Ref import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum (..))+import Data.Foldable (for_) import Data.IORef import Data.Maybe import Data.Monoid ((<>))@@ -52,6 +57,104 @@ import Reflex.Profiled #endif +{-# INLINE mainHydrationWidgetWithHead #-}+mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()+mainHydrationWidgetWithHead = mainHydrationWidgetWithHead'++{-# INLINABLE mainHydrationWidgetWithHead' #-}+-- | Warning: `mainHydrationWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.+mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()+mainHydrationWidgetWithHead' = mainHydrationWidgetWithSwitchoverAction' (pure ())++{-# INLINE mainHydrationWidgetWithSwitchoverAction #-}+mainHydrationWidgetWithSwitchoverAction :: JSM () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()+mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverAction'++{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}+-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.+mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()+mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do+  runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do+    appendHead head'+    appendBody body++{-# INLINABLE attachHydrationWidget #-}+attachHydrationWidget+  :: JSM ()+  -> JSContextSingleton ()+  -> ( Event DomTimeline ()+    -> IORef HydrationMode+    -> Maybe (IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())])+    -> EventChannel+    -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))+     )+  -> IO (a, FireCommand DomTimeline DomHost)+attachHydrationWidget switchoverAction jsSing w = do+  hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating+  rootNodesRef <- liftIO $ newIORef []+  events <- newChan+  runDomHost $ flip runTriggerEventT events $ mdo+    (syncEvent, fireSync) <- newTriggerEvent+    ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do+      a <- w syncEvent hydrationMode (Just rootNodesRef) events+      _ <- runWithReplace (return ()) $ delayedAction <$ syncEvent+      pure a+    mPostBuildTrigger <- readRef postBuildTriggerRef+    lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()+    liftIO $ fireSync ()+    rootNodes <- liftIO $ readIORef rootNodesRef+    let delayedAction = do+          for_ (reverse rootNodes) $ \(rootNode, runner) -> do+            let hydrate = runHydrationRunnerT runner Nothing rootNode events+            void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing+          liftIO $ writeIORef hydrationMode HydrationMode_Immediate+          runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing+    pure (result, fc)++type HydrationWidget x a = HydrationDomBuilderT HydrationDomSpace DomTimeline (DomCoreWidget x) a++-- | A widget that isn't attached to any particular part of the DOM hierarchy+type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)++type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))++{-# INLINABLE runHydrationWidgetWithHeadAndBody #-}+runHydrationWidgetWithHeadAndBody+  :: JSM ()+  -> (   (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"+      -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body"+      -> FloatingWidget () ()+     )+  -> JSM ()+runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do+  globalDoc <- currentDocumentUnchecked+  headElement <- getHeadUnchecked globalDoc+  bodyElement <- getBodyUnchecked globalDoc+  (events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do+    (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef+    let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c+        hydrateDom n w = do+          delayed <- liftIO $ newIORef $ pure ()+          unreadyChildren <- liftIO $ newIORef 0+          lift $ do+            let builderEnv = HydrationDomBuilderEnv+                  { _hydrationDomBuilderEnv_document = globalDoc+                  , _hydrationDomBuilderEnv_parent = Left $ toNode n+                  , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+                  , _hydrationDomBuilderEnv_commitAction = pure ()+                  , _hydrationDomBuilderEnv_hydrationMode = hydrationMode+                  , _hydrationDomBuilderEnv_switchover = switchover+                  , _hydrationDomBuilderEnv_delayed = delayed+                  }+            a <- runHydrationDomBuilderT w builderEnv events+            forM_ hydrationResult $ \hr -> do+              res <- liftIO $ readIORef delayed+              liftIO $ modifyIORef' hr ((n, res) :)+            pure a+    runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing+    return (events, postBuildTriggerRef)+  liftIO $ processAsyncEvents events fc+ {-# INLINE mainWidget #-} mainWidget :: (forall x. Widget x ()) -> JSM () mainWidget = mainWidget'@@ -103,7 +206,7 @@   . runProfiledM #endif -type Widget x = PostBuildT DomTimeline (ImmediateDomBuilderT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))) --TODO: Make this more abstract --TODO: Put the WithJSContext underneath PerformEventT - I think this would perform better because it could avoid fmapping over every performEvent+type Widget x = ImmediateDomBuilderT DomTimeline (DomCoreWidget x)  {-# INLINABLE attachWidget #-} attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a@@ -117,19 +220,24 @@   headFragment <- createDocumentFragment doc   bodyElement <- getBodyUnchecked doc   bodyFragment <- createDocumentFragment doc+  hydrationMode <- liftIO $ newIORef HydrationMode_Immediate   (events, fc) <- liftIO . attachWidget'' $ \events -> do     let (headWidget, bodyWidget) = widgets     (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef     let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c         go w df = do           unreadyChildren <- liftIO $ newIORef 0-          let builderEnv = ImmediateDomBuilderEnv-                { _immediateDomBuilderEnv_document = toDocument doc-                , _immediateDomBuilderEnv_parent = toNode df-                , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren-                , _immediateDomBuilderEnv_commitAction = return () --TODO+          delayed <- liftIO $ newIORef $ pure ()+          let builderEnv = HydrationDomBuilderEnv+                { _hydrationDomBuilderEnv_document = toDocument doc+                , _hydrationDomBuilderEnv_parent = Left $ toNode df+                , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+                , _hydrationDomBuilderEnv_commitAction = return () --TODO+                , _hydrationDomBuilderEnv_switchover = never+                , _hydrationDomBuilderEnv_delayed = delayed+                , _hydrationDomBuilderEnv_hydrationMode = hydrationMode                 }-          runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing+          runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing     rec b <- go (headWidget a) headFragment         a <- go (bodyWidget b) bodyFragment     return (events, postBuildTriggerRef)@@ -148,16 +256,21 @@ attachWidget' rootElement jsSing w = do   doc <- getOwnerDocumentUnchecked rootElement   df <- createDocumentFragment doc+  hydrationMode <- liftIO $ newIORef HydrationMode_Immediate   ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do     (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef     unreadyChildren <- liftIO $ newIORef 0-    let builderEnv = ImmediateDomBuilderEnv-          { _immediateDomBuilderEnv_document = toDocument doc-          , _immediateDomBuilderEnv_parent = toNode df-          , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren-          , _immediateDomBuilderEnv_commitAction = return () --TODO+    delayed <- liftIO $ newIORef $ pure ()+    let builderEnv = HydrationDomBuilderEnv+          { _hydrationDomBuilderEnv_document = toDocument doc+          , _hydrationDomBuilderEnv_parent = Left $ toNode df+          , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+          , _hydrationDomBuilderEnv_commitAction = return () --TODO+          , _hydrationDomBuilderEnv_switchover = never+          , _hydrationDomBuilderEnv_delayed = delayed+          , _hydrationDomBuilderEnv_hydrationMode = hydrationMode           }-    a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing+    a <- runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing     return ((a, events), postBuildTriggerRef)   replaceElementContents rootElement df   liftIO $ processAsyncEvents events fc@@ -186,7 +299,6 @@     liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb   return () - -- | Run a reflex-dom application inside of an existing DOM element with the given ID mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM () mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do@@ -208,7 +320,7 @@   body <- getBodyUnchecked doc   win <- getDefaultViewUnchecked doc   rec o <- attachWidget body jsSing $ do-        w <- lift $ wrapWindow win $ _appOutput_windowConfig o+        w <- wrapWindow win $ _appOutput_windowConfig o         app $ AppInput           { _appInput_window = w           }

@@ -3,86 +3,220 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}++-- | Render the first widget on the server, and the second on the client. module Reflex.Dom.Prerender        ( Prerender (..)-       , prerender+       , prerender_        , PrerenderClientConstraint+       , PrerenderBaseConstraints        ) where +import Control.Monad.Primitive (PrimMonad) import Control.Monad.Reader-import Data.Constraint+import Control.Monad.Ref (MonadRef(..))+import Data.IORef (IORef, newIORef)+import Data.Semigroup (Semigroup)+import Data.Text (Text) import Foreign.JavaScript.TH import GHCJS.DOM.Types (MonadJSM)-import Reflex+import Reflex hiding (askEvents) import Reflex.Dom.Builder.Class-import Reflex.Dom.Builder.InputDisabled 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 -type PrerenderClientConstraint js m =-  ( HasJS js m-  , HasJS js (Performable m)-  , MonadJSM m-  , MonadJSM (Performable m)+import qualified GHCJS.DOM.Document as Document+import qualified GHCJS.DOM.Node as Node+import qualified GHCJS.DOM.Types as DOM++type PrerenderClientConstraint js t m =+  ( DomBuilder t m+  , DomBuilderSpace m ~ GhcjsDomSpace+  , DomRenderHook t m+  , HasDocument m+  , TriggerEvent t m+  , Prerender js t m+  , PrerenderBaseConstraints js t m+  )++type PrerenderBaseConstraints js t m =+  ( HasJSContext (Performable m)   , HasJSContext m-  , HasJSContext (Performable m)   , MonadFix m-  , MonadFix (Performable m)-  , DomBuilderSpace m ~ GhcjsDomSpace+  , MonadHold t m+  , MonadJSM (Performable m)+  , MonadJSM m+  , MonadRef (Performable m)+  , MonadRef m+  , MonadReflexCreateTrigger t m+  , MonadSample t (Performable m)+  , PerformEvent t m+  , PostBuild t m+  , PrimMonad m+  , Ref (Performable m) ~ IORef+  , Ref m ~ IORef+  , HasJS js m+  , HasJS js (Performable m)   ) -class Prerender js m | m -> js where-  prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m))+-- | Render the first widget on the server, and the second on the client. The+-- hydration builder will run *both* widgets.+prerender_+  :: (Functor m, Reflex t, Prerender js t m)+  => m () -> ((PrerenderClientConstraint js t (Client m)) => Client m ()) -> m ()+prerender_ server client = void $ prerender server client --- | Draw one widget when prerendering (e.g. server-side) and another when the--- widget is fully instantiated.  In a given execution of this function, there--- will be exactly one invocation of exactly one of the arguments.-prerender :: forall js m a. Prerender js m => m a -> (PrerenderClientConstraint js m => m a) -> m a-prerender server client = case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of-  Nothing -> server-  Just Dict -> client+class 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) -instance ( HasJS js m-         , HasJS js (Performable m)-         , HasJSContext m-         , HasJSContext (Performable m)-         , MonadJSM m-         , MonadJSM (Performable m)-         , MonadFix m-         , MonadFix (Performable m)-         , ReflexHost t-         ) => Prerender js (ImmediateDomBuilderT t m) where-  prerenderClientDict = Just Dict+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+  prerender _ client = pure <$> client +instance (Adjustable t m, PrerenderBaseConstraints js t m, ReflexHost t) => Prerender js t (HydrationDomBuilderT HydrationDomSpace t m) where+  -- | PostBuildT is needed here because we delay running the client builder+  -- until after switchover, at which point the postBuild of @m@ has already fired+  type Client (HydrationDomBuilderT HydrationDomSpace t m) = PostBuildT t (HydrationDomBuilderT GhcjsDomSpace t m)+  -- | Runs the server widget up until switchover, then replaces it with the+  -- client widget.+  prerender server client = do+    env <- HydrationDomBuilderT ask+    events <- askEvents+    doc <- askDocument+    serverDf <- Document.createDocumentFragment doc -- server dom should not be mounted in the window's doc in hydration+    df <- Document.createDocumentFragment doc+    unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren+    immediateMode <- liftIO $ newIORef HydrationMode_Immediate+    delayed <- liftIO $ newIORef $ pure ()+    let clientEnv = env+          { _hydrationDomBuilderEnv_parent = Left $ DOM.toNode df+          , _hydrationDomBuilderEnv_hydrationMode = immediateMode+          }+        serverEnv = HydrationDomBuilderEnv+          { _hydrationDomBuilderEnv_document = doc+          , _hydrationDomBuilderEnv_parent = Left $ DOM.toNode serverDf+          , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren+          , _hydrationDomBuilderEnv_commitAction = pure ()+          , _hydrationDomBuilderEnv_delayed = delayed+          , _hydrationDomBuilderEnv_hydrationMode = immediateMode+          , _hydrationDomBuilderEnv_switchover = never+          }+    a0 <- lift $ runHydrationDomBuilderT server serverEnv events+    (a', trigger) <- newTriggerEvent+    getHydrationMode >>= \case+      HydrationMode_Immediate -> do+        liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void a') clientEnv events+        append $ DOM.toNode df+      HydrationMode_Hydrating -> addHydrationStep $ do+        liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void a') clientEnv events+        insertBefore df =<< deleteToPrerenderEnd doc+    holdDyn a0 a'+ data NoJavaScript -- This type should never have a HasJS instance -instance js ~ NoJavaScript => Prerender js (StaticDomBuilderT t m) where-  prerenderClientDict = Nothing+instance (js ~ NoJavaScript, SupportsStaticDomBuilder t m) => Prerender js t (StaticDomBuilderT t m) where+  type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m+  prerender server _ = do+    _ <- commentNode $ CommentNodeConfig startMarker Nothing+    a <- server+    _ <- commentNode $ CommentNodeConfig endMarker Nothing+    pure $ pure a -instance (Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+instance (Prerender js t m, Monad m) => Prerender js t (ReaderT r m) where+  type Client (ReaderT r m) = ReaderT r (Client m)+  prerender server client = do+    r <- ask+    lift $ prerender (runReaderT server r) (runReaderT client r) -instance Prerender js m => Prerender js (DynamicWriterT t w m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+instance (Prerender js t m, Monad m, Reflex t, MonadFix m, Monoid w) => Prerender js t (DynamicWriterT t w m) where+  type Client (DynamicWriterT t w m) = DynamicWriterT t w (Client m)+  prerender server client = do+    x <- lift $ prerender (runDynamicWriterT server) (runDynamicWriterT client)+    let (a, w') = splitDynPure x+        w = join w'+    tellDyn w+    pure a -instance Prerender js m => Prerender js (EventWriterT t w m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+instance (Prerender js t m, Monad m, Reflex t, Semigroup w) => Prerender js t (EventWriterT t w m) where+  type Client (EventWriterT t w m) = EventWriterT t w (Client m)+  prerender server client = do+    x <- lift $ prerender (runEventWriterT server) (runEventWriterT client)+    let (a, w') = splitDynPure x+        w = switch $ current w'+    tellEvent w+    pure a -instance Prerender js m => Prerender js (ReaderT w m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+instance (Prerender js t m, MonadFix m, Reflex t) => Prerender js t (RequesterT t request response m) where+  type Client (RequesterT t request response m) = RequesterT t request response (Client m)+  prerender server client = mdo+    let fannedResponses = fanInt responses+        withFannedResponses :: forall m' a. Monad m' => RequesterT t request response m' a -> Int -> m' (a, Event t (IntMap (RequesterData request)))+        withFannedResponses w selector = do+          (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 -instance Prerender js m => Prerender js (RequesterT t request response m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+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)+  prerender server client = mdo+    result <- queryDyn query+    x <- lift $ prerender (runQueryT server result) (runQueryT client result)+    let (a, inc) = splitDynPure x+        query = incrementalToDynamic =<< inc -- Can we avoid the incrementalToDynamic?+    pure a -instance Prerender js m => Prerender js (QueryT t q m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+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 -instance Prerender js m => Prerender js (InputDisabledT m) where-  prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))+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)+  prerender server client = PostBuildT $ do+    pb <- ask+    lift $ prerender (runPostBuildT server pb) (runPostBuildT client pb)++startMarker, endMarker :: Text+startMarker = "prerender/start"+endMarker = "prerender/end"++deleteToPrerenderEnd :: (MonadIO m, MonadJSM m, Reflex t, MonadFix m) => DOM.Document -> HydrationRunnerT t m DOM.Comment+deleteToPrerenderEnd doc = do+  startNode <- hydrateComment doc startMarker Nothing+  let go (n :: Int) lastNode = Node.getNextSibling lastNode >>= \case+        Nothing -> do+          c <- Document.createComment doc endMarker+          insertAfterPreviousNode c+          pure c+        Just node -> DOM.castTo DOM.Comment node >>= \case+          Nothing -> go n node+          Just c -> Node.getTextContentUnchecked c >>= \case+            t | t == startMarker -> go (succ n) node+              | t == endMarker -> case n of+                0 -> pure c+                _ -> go (pred n) node+              | otherwise -> go n node+  endNode <- go 0 $ DOM.toNode startNode+  deleteBetweenExclusive startNode endNode+  setPreviousNode $ Just $ DOM.toNode endNode+  pure endNode

@@ -1,62 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Reflex.Dom.Specializations where--import Data.Text (Text)-import Reflex.Spider-import Reflex.Class-import Foreign.JavaScript.TH-import Reflex.PerformEvent.Base-import Reflex.PostBuild.Base-import Reflex.Requester.Base-import Reflex.TriggerEvent.Base-import Reflex.Dom.Builder.Class-import Reflex.Dom.Builder.Immediate-import Data.Functor.Identity-import Data.Functor.Compose-import Data.IORef-import GHCJS.DOM.Types (JSM)-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap--import qualified GHCJS.DOM.Element as DOM-import qualified GHCJS.DOM.Types as DOM--{-# SPECIALIZE makeElement :: forall er a. Text -> ElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) ((Element er GhcjsDomSpace (SpiderTimeline Global), a), DOM.Element) #-}--{-# SPECIALIZE wrap :: forall er. RawElement GhcjsDomSpace -> RawElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (Element er GhcjsDomSpace (SpiderTimeline Global)) #-}--{-# SPECIALIZE mapIntMapWithAdjustImpl :: forall v v'.-     (   (IntMap.Key -> (Event (SpiderTimeline Global) (), v) -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')-      -> IntMap (Event (SpiderTimeline Global) (), v)-      -> Event (SpiderTimeline Global) (PatchIntMap (Event (SpiderTimeline Global) (), v))-      -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))-     )-  -> (IntMap.Key -> v -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')-  -> IntMap v-  -> Event (SpiderTimeline Global) (PatchIntMap v)-  -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))-  #-}--{-# SPECIALIZE append :: DOM.Node -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) () #-}--{-# SPECIALIZE drawChildUpdate :: forall k v' a. ImmediateDomBuilderEnv (SpiderTimeline Global) -> (IORef (ChildReadyState k) -> JSM ()) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a) -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a) #-}--{-# SPECIALIZE traverseIntMapWithKeyWithAdjust' :: forall v v'. (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v') -> IntMap v -> Event (SpiderTimeline Global) (PatchIntMap v) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) #-}--{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust :: forall v v'.-     (   (IntMap.Key -> v -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))-      -> IntMap v-      -> Event (SpiderTimeline Global) (PatchIntMap v)-      -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event (SpiderTimeline Global) (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))-     )-  -> (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt)))-  -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ())-  -> (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v')-  -> IntMap v-  -> Event (SpiderTimeline Global) (PatchIntMap v)-  -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))-  #-}

@@ -14,6 +14,8 @@   -- * Displaying Values     text   , dynText+  , comment+  , dynComment   , display   , button   , dyn@@ -114,6 +116,19 @@ dynText t = do   postBuild <- getPostBuild   void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost+    [ updated t+    , tag (current t) postBuild+    ]+  notReadyUntil postBuild++comment :: DomBuilder t m => Text -> m ()+comment t = void $ commentNode $ def & commentNodeConfig_initialContents .~ t++{-# INLINABLE dynComment #-}+dynComment :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()+dynComment t = do+  postBuild <- getPostBuild+  void $ commentNode $ (def :: CommentNodeConfig t) & commentNodeConfig_setContents .~ leftmost     [ updated t     , tag (current t) postBuild     ]

@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Reflex.Dom.Xhr.FormData+  ( postForms+  , FormValue (..)+  , fileToFormValue+  )+  where++import Control.Lens+import Data.Default+import Data.Map (Map)+import Data.Text (Text)+import Data.Traversable+import qualified GHCJS.DOM.FormData as FD+import Foreign.JavaScript.TH+import GHCJS.DOM.File (getName)+import GHCJS.DOM.Types (File, IsBlob)+import Language.Javascript.JSaddle.Monad (MonadJSM, liftJSM)+import Reflex+import Reflex.Dom.Xhr++-- | A FormData value may be a blob/file or a string. The file can optionally be provided with filename.+data FormValue blob = FormValue_Text Text+                    | FormValue_File blob (Maybe Text) -- maybe filename++-- | Performs a POST request with the provided FormData payload+postForms+  :: ( IsBlob blob, HasJSContext (Performable m), MonadJSM (Performable m)+     , PerformEvent t m, TriggerEvent t m+     , Traversable f)+  => Text -- ^ The target url+  -> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData"+  -> m (Event t (f XhrResponse))+postForms url payload = do+  performMkRequestsAsync $ ffor payload $ \fs -> for fs $ \u -> liftJSM $ do+    fd <- FD.newFormData Nothing+    iforM_ u $ \k v -> case v of+      FormValue_Text t -> FD.append fd k t+      FormValue_File b fn -> FD.appendBlob fd k b fn+    return $ xhrRequest "POST" url $ def & xhrRequestConfig_sendData .~ fd++-- | Converts a File (e.g., the output of a 'FileInput') into a 'FormValue'. The filename will be included if it is available.+fileToFormValue :: MonadJSM m => File -> m (FormValue File)+fileToFormValue f = do+  fn <- getName f+  return $ FormValue_File f $ Just fn

@@ -8,16 +8,17 @@ import Control.Monad import Control.Monad.IO.Class import Data.Int+import Data.Text as T import Language.Javascript.JSaddle.Warp import Reflex.Dom.Core import Reflex.Time import System.Exit-import System.IO.Temp-import System.Linux.Namespaces import System.Mem-import System.Posix import System.Process +import Test.Util.ChromeFlags+import Test.Util.UnshareNetwork+ #if MIN_VERSION_base(4,11,0) import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc) currentBytesUsed :: RTSStats -> Int64@@ -46,14 +47,14 @@  main :: IO () main = do-  uid <- getEffectiveUserID-  handle (\(_ :: IOError) -> return ()) $ do -- If we run into an exception with sandboxing, just don't bother-    unshare [User, Network]-    writeUserMappings Nothing [UserMapping 0 uid 1]-    callCommand "ip link set lo up ; ip addr"-  mainThread <- myThreadId-  withSystemTempDirectory "reflex-dom-core_test_gc" $ \tmp -> do-    browserProcess <- spawnCommand $ "echo 'Starting Chromium' ; chromium --headless --disable-gpu --no-sandbox --remote-debugging-port=9222 --user-data-dir=" ++ tmp ++ " http://localhost:3911 ; echo 'Chromium exited'"+  handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother+  withSandboxedChromeFlags True $ \chromeFlags -> do+    mainThread <- myThreadId+    browserProcess <- spawnCommand $ mconcat+      [ "echo 'Starting Chromium' ; chromium "+      , unpack $ T.unwords chromeFlags+      , " http://localhost:3911 ; echo 'Chromium exited'"+      ]     let finishTest result = do           interruptProcessGroupOf browserProcess           throwTo mainThread result

@@ -0,0 +1,1428 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++import Control.Concurrent+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.Ref+import Data.Constraint.Extras+import Data.Constraint.Extras.TH+import Data.Dependent.Map (DMap)+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))+import Data.Functor.Identity+import Data.Functor.Misc+import Data.GADT.Compare.TH+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)+import Language.Javascript.JSaddle.Warp+import Network.HTTP.Types (status200)+import Network.Socket+import Network.Wai+import Network.WebSockets+import Reflex.Dom.Core+import Reflex.Patch.DMapWithMove+import System.Directory+import System.Environment+import System.IO (stderr)+import System.IO.Silently+import System.IO.Temp+import System.Process+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)+import qualified Test.Hspec 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 qualified Data.ByteString.Lazy as LBS+import qualified Data.Dependent.Map as DMap+import qualified Data.IntMap as IntMap+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified GHCJS.DOM.File as File+import qualified Network.Wai.Handler.Warp as Warp+import qualified System.FilePath as FilePath+import qualified Test.WebDriver as WD+import qualified Test.WebDriver.Capabilities as WD++import Test.Util.ChromeFlags+import Test.Util.UnshareNetwork++seleniumPort, jsaddlePort :: PortNumber+seleniumPort = 8000+jsaddlePort = 8001++-- TODO Remove orphan+instance MonadRef WD where+  type Ref WD = Ref IO+  newRef = WD . newRef+  readRef = WD . readRef+  writeRef r = WD . writeRef r++assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()+assertEqual a b = liftIO . HUnit.assertEqual a b++assertFailure :: MonadIO m => String -> m ()+assertFailure = liftIO . HUnit.assertFailure++chromeConfig :: Text -> [Text] -> WD.WDConfig+chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig++keyMap :: DMap DKey Identity+keyMap = DMap.fromList+  [ Key_Int ==> 0+  , Key_Char ==> 'A'+  ]++data DKey a where+  Key_Int :: DKey Int+  Key_Char :: DKey Char+  Key_Bool :: DKey Bool+++textKey :: DKey a -> Text+textKey = \case+  Key_Int -> "Key_Int"+  Key_Char -> "Key_Char"+  Key_Bool -> "Key_Bool"++deriveArgDict ''DKey+deriveGEq ''DKey+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 = (==)++main :: IO ()+main = do+  unshareNetork+  isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"+  withSandboxedChromeFlags isHeadless $ \chromeFlags -> do+    withSeleniumServer $ \selenium -> do+      browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""+      when (T.null browserPath) $ fail "No browser found"+      withDebugging <- isJust <$> lookupEnv "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++tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec+tests withDebugging wdConfig caps _selenium = do+  let putStrLnDebug :: MonadIO m => Text -> m ()+      putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m+      session' = sessionWith wdConfig "" . using (map (,"") caps)+      runWD m = runWDOptions (WdOptions False) $ do+        putStrLnDebug "before"+        r <- m+        putStrLnDebug "after"+        return r+      testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b+      testWidgetStatic = testWidgetStaticDebug withDebugging+      testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b+      testWidget = testWidgetDebug withDebugging+      testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b+      testWidget' = testWidgetDebug' withDebugging+  describe "text" $ session' $ do+    it "works" $ runWD $ do+      testWidgetStatic (checkBodyText "hello world") $ do+        text "hello world"+    it "works with postBuild" $ runWD $ do+      testWidgetStatic (checkBodyText "pb") $ do+        pb <- getPostBuild+        void $ textNode $ TextNodeConfig "" $ Just $ "pb" <$ pb+    it "works for adjacent text nodes" $ runWD $ do+      testWidgetStatic (checkBodyText "hello world") $ do+        text "hello "+        text "world"+    it "works for empty adjacent text nodes" $ runWD $ do+      testWidgetStatic (checkBodyText "hello world") $ do+        pb <- getPostBuild+        text ""+        text ""+        _ <- textNode $ TextNodeConfig "" $ Just $ "hello " <$ pb+        _ <- textNode $ TextNodeConfig "abc" $ Just $ "" <$ pb+        _ <- textNode $ TextNodeConfig "" $ Just $ "world" <$ pb+        text ""+    it "works when empty text nodes are the only children of an element" $ runWD $ do+      testWidgetStatic (checkBodyText "hello world") $ do+        el "div" $ do+          text ""+          text ""+        text "hello world"+    it "works when an empty text node is the first child before text" $ runWD $ do+      testWidgetStatic (checkTextInTag "div" "hello world") $ do+        el "div" $ do+          text ""+          text "hello world"+    it "works when an empty text node is the first child before element" $ runWD $ do+      testWidgetStatic (checkTextInTag "div" "hello world") $ do+        el "div" $ do+          text ""+          el "span" $ text "hello world"+    it "works when an empty text node is the last child" $ runWD $ do+      testWidgetStatic (checkTextInTag "div" "hello world") $ do+        el "div" $ do+          el "span" $ text "hello world"+          text ""+-- TODO I think these two tests are broken+--    it "updates after postBuild" $ runWD $ do+--      testWidget (checkBodyText "initial") (checkBodyText "after") $ do+--        after <- delay 0 =<< getPostBuild+--        void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after+--    it "updates immediately after postBuild" $ runWD $ do+--      testWidget (checkBodyText "pb") (checkBodyText "after") $ do+--        pb <- getPostBuild+--        after <- delay 0 pb+--        void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]+    it "updates in immediate mode" $ runWD $ do+      let checkUpdated = do+            checkBodyText "initial"+            WD.click =<< findElemWithRetry (WD.ByTag "button")+            checkBodyText "after"+      testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do+        click <- button ""+        void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click++  describe "element" $ session' $ do+    it "works with domEvent Click" $ runWD $ do+      clickedRef <- liftIO $ newRef False+      testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do+        (e, _) <- el' "div" $ text "hello world"+        performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e+      readRef clickedRef `shouldBeWithRetryM` True+    it "works with eventFlags stopPropagation" $ runWD $ do+      firstClickedRef <- newRef False+      secondClickedRef <- newRef False+      let clickBoth = do+            findElemWithRetry (WD.ById "first") >>= WD.click+            findElemWithRetry (WD.ById "second") >>= WD.click+      testWidget (pure ()) clickBoth $ do+        (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do+          void $ elAttr "span" ("id" =: "first") $ text "hello world"+        performEvent_ $ liftIO (writeRef firstClickedRef True) <$ domEvent Click firstDivEl+        (secondDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do+          let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace+              conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)+                & initialAttributes .~ "id" =: "second"+                & elementConfig_eventSpec .~ addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> stopPropagation) def+          void $ element "span" conf $ text "hello world"+        performEvent_ $ liftIO (writeRef secondClickedRef True) <$ domEvent Click secondDivEl+      firstClicked <- readRef firstClickedRef+      secondClicked <- readRef secondClickedRef+      assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)+    it "works with eventFlags preventDefault" $ runWD $ do+      let click = do+            e <- findElemWithRetry $ WD.ByTag "input"+            s0 <- WD.isSelected e+            WD.click e+            s1 <- WD.isSelected e+            pure (s0, s1)+      clicked <- testWidget (pure ()) click $ prerender_ (pure ()) $ do+        let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace+            conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)+              & elementConfig_eventSpec .~ addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> preventDefault) def+              & initialAttributes .~ "type" =: "checkbox"+        void $ element "input" conf $ text "hello world"+      assertEqual "Click not prevented" (False, False) clicked+    it "can add/update/remove attributes" $ runWD $ do+      let checkInitialAttrs = do+            e <- findElemWithRetry $ WD.ByTag "div"+            assertAttr e "const" (Just "const")+            assertAttr e "delete" (Just "delete")+            assertAttr e "init" (Just "init")+            assertAttr e "click" Nothing+            pure e+          checkModifyAttrs e = do+            WD.click e+            withRetry $ do+              assertAttr e "const" (Just "const")+              assertAttr e "delete" Nothing+              assertAttr e "init" (Just "click")+              assertAttr e "click" (Just "click")+      testWidget' checkInitialAttrs checkModifyAttrs $ mdo+        let conf = def+              & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"+              & modifyAttributes .~ (("delete" =: Nothing <> "init" =: Just "click" <> "click" =: Just "click") <$ click)+        (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+      it "doesn't wipe user input when switching over" $ runWD $ do+        inputRef <- newRef ("" :: Text)+        testWidget'+          (do+            e <- findElemWithRetry $ WD.ByTag "input"+            WD.sendKeys "hello world" e+            pure e)+          (\e -> do+            WD.attr e "value" `shouldBeWithRetryM` Just "hello world"+            WD.click =<< findElemWithRetry (WD.ByTag "button")+            readRef inputRef `shouldBeWithRetryM` "hello world"+          ) $ do+          e <- inputElement def+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click+      it "captures user input after switchover" $ runWD $ do+        inputRef <- newRef ("" :: Text)+        let checkValue = do+              WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              readRef inputRef `shouldBeWithRetryM` "hello world"+        testWidget (pure ()) checkValue $ do+          e <- inputElement def+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click+      it "sets focus appropriately" $ runWD $ do+        focusRef <- newRef False+        let checkValue = do+              readRef focusRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.click e+              readRef focusRef `shouldBeWithRetryM` True+        testWidget (pure ()) checkValue $ do+          e <- inputElement def+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)+      it "sets focus when focus occurs before hydration" $ runWD $ do+        focusRef <- newRef False+        let setup = do+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.click e+              ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True+              readRef focusRef `shouldBeWithRetryM` False+            check = readRef focusRef `shouldBeWithRetryM` True+        testWidget setup check $ do+          e <- inputElement def+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)+      it "sets value appropriately" $ runWD $ do+        valueByUIRef <- newRef ("" :: Text)+        valueRef <- newRef ("" :: Text)+        setValueChan :: Chan Text <- liftIO newChan+        let checkValue = do+              readRef valueByUIRef `shouldBeWithRetryM` ""+              readRef valueRef `shouldBeWithRetryM` ""+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.sendKeys "hello" e+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "hello"+              liftIO $ writeChan setValueChan "world"+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "world"+        testWidget (pure ()) checkValue $ do+          update <- triggerEventWithChan setValueChan+          e <- inputElement $ def & inputElementConfig_setValue .~ update+          performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e+          performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)+      it "sets checked appropriately" $ runWD $ do+        checkedByUIRef <- newRef False+        checkedRef <- newRef False+        setCheckedChan <- liftIO newChan+        let checkValue = do+              readRef checkedByUIRef `shouldBeWithRetryM` False+              readRef checkedRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.moveToCenter e+              WD.click e+              readRef checkedByUIRef `shouldBeWithRetryM` True+              readRef checkedRef `shouldBeWithRetryM` True+              liftIO $ writeChan setCheckedChan False+              readRef checkedByUIRef `shouldBeWithRetryM` True+              readRef checkedRef `shouldBeWithRetryM` False+        testWidget (pure ()) checkValue $ do+          setChecked <- triggerEventWithChan setCheckedChan+          e <- inputElement $ def+            & initialAttributes .~ "type" =: "checkbox"+            & inputElementConfig_setChecked .~ setChecked+          performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e+          performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)+      it "captures file uploads" $ runWD $ do+        filesRef :: IORef [Text] <- newRef []+        let uploadFile = do+              e <- findElemWithRetry $ WD.ByTag "input"+              path <- liftIO $ writeSystemTempFile "testFile" "file contents"+              WD.sendKeys (T.pack path) e+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              liftIO $ removeFile path+              readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]+        testWidget (pure ()) uploadFile $ do+          e <- inputElement $ def & initialAttributes .~ "type" =: "file"+          click <- button "save"+          prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do+            names <- liftJSM $ traverse File.getName fs+            liftIO $ writeRef filesRef names++    describe "hydration/immediate" $ session' $ do+      it "captures user input after switchover" $ runWD $ do+        inputRef :: IORef Text <- newRef ""+        let checkValue = do+              WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              readRef inputRef `shouldBeWithRetryM` "hello world"+        testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do+          e <- inputElement def+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click+      it "sets focus appropriately" $ runWD $ do+        focusRef <- newRef False+        let checkValue = do+              readRef focusRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.click e+              readRef focusRef `shouldBeWithRetryM` True+        testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do+          e <- inputElement def+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)+      it "sets value appropriately" $ runWD $ do+        valueByUIRef :: IORef Text <- newRef ""+        valueRef :: IORef Text <- newRef ""+        setValueChan :: Chan Text <- liftIO newChan+        let checkValue = do+              readRef valueByUIRef `shouldBeWithRetryM` ""+              readRef valueRef `shouldBeWithRetryM` ""+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.sendKeys "hello" e+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "hello"+              liftIO $ writeChan setValueChan "world"+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "world"+        testWidget (pure ()) checkValue $ do+          update <- triggerEventWithChan setValueChan+          prerender_ (pure ()) $ do+            e <- inputElement $ def & inputElementConfig_setValue .~ update+            performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e+            performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)+      it "sets checked appropriately" $ runWD $ do+        checkedByUIRef <- newRef False+        checkedRef <- newRef False+        setCheckedChan <- liftIO newChan+        let checkValue = do+              readRef checkedByUIRef `shouldBeWithRetryM` False+              readRef checkedRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "input"+              WD.moveToCenter e+              WD.click e+              readRef checkedByUIRef `shouldBeWithRetryM` True+              readRef checkedRef `shouldBeWithRetryM` True+              liftIO $ writeChan setCheckedChan False+              readRef checkedByUIRef `shouldBeWithRetryM` True+              readRef checkedRef `shouldBeWithRetryM` False+        testWidget (pure ()) checkValue $ do+          setChecked <- triggerEventWithChan setCheckedChan+          prerender_ (pure ()) $ do+            e <- inputElement $ def+              & initialAttributes .~ "type" =: "checkbox"+              & inputElementConfig_setChecked .~ setChecked+            performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e+            performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)+      it "captures file uploads" $ runWD $ do+        filesRef :: IORef [Text] <- newRef []+        let uploadFile = do+              e <- findElemWithRetry $ WD.ByTag "input"+              path <- liftIO $ writeSystemTempFile "testFile" "file contents"+              WD.sendKeys (T.pack path) e+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              liftIO $ removeFile path+              readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]+        testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do+          e <- inputElement $ def & initialAttributes .~ "type" =: "file"+          click <- button "save"+          performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do+            names <- liftJSM $ traverse File.getName fs+            liftIO $ writeRef filesRef names++  describe "textAreaElement" $ do+    describe "hydration" $ session' $ do+      it "doesn't wipe user input when switching over" $ runWD $ do+        inputRef <- newRef ("" :: Text)+        testWidget'+          (do+            e <- findElemWithRetry $ WD.ByTag "textarea"+            WD.sendKeys "hello world" e+            pure e)+          (\e -> do+            WD.attr e "value" `shouldBeWithRetryM` Just "hello world"+            WD.click <=< findElemWithRetry $ WD.ByTag "button"+            readRef inputRef `shouldBeWithRetryM` "hello world"+          ) $ do+          e <- textAreaElement def+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click+      it "captures user input after switchover" $ runWD $ do+        inputRef <- newRef ("" :: Text)+        let checkValue = do+              WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              readRef inputRef `shouldBeWithRetryM` "hello world"+        testWidget (pure ()) checkValue $ do+          e <- textAreaElement def+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click+      it "sets focus appropriately" $ runWD $ do+        focusRef <- newRef False+        let checkValue = do+              readRef focusRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "textarea"+              WD.click e+              readRef focusRef `shouldBeWithRetryM` True+        testWidget (pure ()) checkValue $ do+          e <- textAreaElement def+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)+      it "sets focus when focus occurs before hydration" $ runWD $ do+        focusRef <- newRef False+        let setup = do+              e <- findElemWithRetry $ WD.ByTag "textarea"+              WD.click e+              ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True+              readRef focusRef `shouldBeWithRetryM` False+            check = readRef focusRef `shouldBeWithRetryM` True+        testWidget setup check $ do+          e <- textAreaElement def+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)+      it "sets value appropriately" $ runWD $ do+        valueByUIRef <- newRef ("" :: Text)+        valueRef <- newRef ("" :: Text)+        setValueChan :: Chan Text <- liftIO newChan+        let checkValue = do+              readRef valueByUIRef `shouldBeWithRetryM` ""+              readRef valueRef `shouldBeWithRetryM` ""+              e <- findElemWithRetry $ WD.ByTag "textarea"+              WD.sendKeys "hello" e+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "hello"+              liftIO $ writeChan setValueChan "world"+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "world"+        testWidget (pure ()) checkValue $ do+          setValue' <- triggerEventWithChan setValueChan+          e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }+          performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e+          performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)++    describe "hydration/immediate" $ session' $ do+      it "captures user input after switchover" $ runWD $ do+        inputRef :: IORef Text <- newRef ""+        let checkValue = do+              WD.sendKeys "hello world" <=< findElemWithRetry $ WD.ByTag "textarea"+              WD.click <=< findElemWithRetry $ WD.ByTag "button"+              readRef inputRef `shouldBeWithRetryM` "hello world"+        testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do+          e <- textAreaElement def+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click+      it "sets focus appropriately" $ runWD $ do+        focusRef <- newRef False+        let checkValue = do+              readRef focusRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "textarea"+              WD.click e+              readRef focusRef `shouldBeWithRetryM` True+        testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do+          e <- textAreaElement def+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)+      it "sets value appropriately" $ runWD $ do+        valueByUIRef :: IORef Text <- newRef ""+        valueRef :: IORef Text <- newRef ""+        setValueChan :: Chan Text <- liftIO newChan+        let checkValue = do+              readRef valueByUIRef `shouldBeWithRetryM` ""+              readRef valueRef `shouldBeWithRetryM` ""+              e <- findElemWithRetry $ WD.ByTag "textarea"+              WD.sendKeys "hello" e+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "hello"+              liftIO $ writeChan setValueChan "world"+              readRef valueByUIRef `shouldBeWithRetryM` "hello"+              readRef valueRef `shouldBeWithRetryM` "world"+        testWidget (pure ()) checkValue $ do+          setValue' <- triggerEventWithChan setValueChan+          prerender_ (pure ()) $ do+            e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }+            performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e+            performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)++  describe "selectElement" $ do+    let options :: DomBuilder t m => m ()+        options = do+          elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"+          elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"+          elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"+    describe "hydration" $ session' $ do+      it "sets initial value correctly" $ runWD $ do+        inputRef <- newRef ("" :: Text)+        let setup = do+              e <- findElemWithRetry $ WD.ByTag "select"+              assertAttr e "value" (Just "three")+              WD.click =<< findElemWithRetry (WD.ById "two")+              pure e+            check e = do+              assertAttr e "value" (Just "two")+              readRef inputRef `shouldBeWithRetryM` "three"+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              assertAttr e "value" (Just "two")+              readRef inputRef `shouldBeWithRetryM` "two"+        testWidget' setup check $ do+          (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options+          click <- button "save"+          liftIO . writeRef inputRef <=< sample $ current $ _selectElement_value e+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (_selectElement_value e)) click+      it "captures user input after switchover" $ runWD $ do+        inputRef <- newRef ("" :: Text)+        let checkValue = do+              e <- findElemWithRetry $ WD.ByTag "select"+              assertAttr e "value" (Just "one")+              WD.click =<< findElemWithRetry (WD.ById "two")+              assertAttr e "value" (Just "two")+              WD.click =<< findElemWithRetry (WD.ByTag "button")+              readRef inputRef `shouldBeWithRetryM` "two"+        testWidget (pure ()) checkValue $ do+          (e, ()) <- selectElement def options+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (_selectElement_value e)) click+      it "sets focus appropriately" $ runWD $ do+        focusRef <- newRef False+        let checkValue = do+              readRef focusRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "select"+              WD.click e+              readRef focusRef `shouldBeWithRetryM` True+        testWidget (pure ()) checkValue $ do+          (e, ()) <- selectElement def options+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)+      it "sets focus when focus occurs before hydration" $ runWD $ do+        focusRef <- newRef False+        let setup = do+              e <- findElemWithRetry $ WD.ByTag "select"+              WD.click e+              ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True+              readRef focusRef `shouldBeWithRetryM` False+            check = readRef focusRef `shouldBeWithRetryM` True+        testWidget setup check $ do+          (e, ()) <- selectElement def options+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)+      it "sets value appropriately" $ runWD $ do+        valueByUIRef <- newRef ("" :: Text)+        valueRef <- newRef ("" :: Text)+        setValueChan :: Chan Text <- liftIO newChan+        let checkValue = do+              e <- findElemWithRetry $ WD.ByTag "select"+              assertAttr e "value" (Just "one")+              readRef valueByUIRef `shouldBeWithRetryM` "one"+              readRef valueRef `shouldBeWithRetryM` "one"+              WD.click <=< findElemWithRetry $ WD.ById "two"+              readRef valueByUIRef `shouldBeWithRetryM` "two"+              readRef valueRef `shouldBeWithRetryM` "two"+              liftIO $ writeChan setValueChan "three"+              readRef valueByUIRef `shouldBeWithRetryM` "two"+              readRef valueRef `shouldBeWithRetryM` "three"+        testWidget (pure ()) checkValue $ do+          setValue' <- triggerEventWithChan setValueChan+          (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options+          performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e+          performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)++    describe "hydration/immediate" $ session' $ do+      it "captures user input after switchover" $ runWD $ do+        inputRef :: IORef Text <- newRef ""+        let checkValue = do+              WD.click <=< findElemWithRetry $ WD.ById "two"+              WD.click <=< findElemWithRetry $ WD.ByTag "button"+              readRef inputRef `shouldBeWithRetryM` "two"+        testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do+          (e, ()) <- selectElement def options+          click <- button "save"+          performEvent_ $ liftIO . writeRef inputRef <$> tag (current (_selectElement_value e)) click+      it "sets focus appropriately" $ runWD $ do+        focusRef <- newRef False+        let checkValue = do+              readRef focusRef `shouldBeWithRetryM` False+              e <- findElemWithRetry $ WD.ByTag "select"+              WD.click e+              readRef focusRef `shouldBeWithRetryM` True+        testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do+          (e, ()) <- selectElement def options+          performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)+      it "has correct initial value" $ runWD $ do+        valueRef :: IORef Text <- newRef ""+        let checkValue = readRef valueRef `shouldBeWithRetryM` "one"+        testWidget (pure ()) checkValue $ do+          prerender_ (pure ()) $ do+            (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options+            liftIO . writeRef valueRef <=< sample $ current $ _selectElement_value e+      it "sets value appropriately" $ runWD $ do+        valueByUIRef :: IORef Text <- newRef ""+        valueRef :: IORef Text <- newRef ""+        setValueChan :: Chan Text <- liftIO newChan+        let checkValue = do+              WD.click =<< findElemWithRetry (WD.ById "two")+              readRef valueByUIRef `shouldBeWithRetryM` "two"+              readRef valueRef `shouldBeWithRetryM` "two"+              liftIO $ writeChan setValueChan "three"+              readRef valueByUIRef `shouldBeWithRetryM` "two"+              readRef valueRef `shouldBeWithRetryM` "three"+        testWidget (pure ()) checkValue $ do+          setValue' <- triggerEventWithChan setValueChan+          prerender_ (pure ()) $ do+            (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options+            performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e+            performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)++  describe "prerender" $ session' $ do+    it "works in simple case" $ runWD $ do+      testWidget (checkBodyText "One") (checkBodyText "Two") $ do+        prerender_ (text "One") (text "Two")+    it "removes element correctly" $ runWD $ do+      testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do+        prerender_ (el "span" $ text "One") (text "Two")+    it "can be nested in server widget" $ runWD $ do+      testWidget (checkBodyText "One") (checkBodyText "Three") $ do+        prerender_ (prerender_ (text "One") (text "Two")) (text "Three")+    it "can be nested in client widget" $ runWD $ do+      testWidget (checkBodyText "One") (checkBodyText "Three") $ do+        prerender_ (text "One") (prerender_ (text "Two") (text "Three"))+    it "works with prerender_ siblings" $ runWD $ do+      testWidget+        (checkTextInId "a1" "One" >> checkTextInId "b1" "Three" >> checkTextInId "c1" "Five")+        (checkTextInId "a2" "Two" >> checkTextInId "b2" "Four" >> checkTextInId "c2" "Six") $ do+          prerender_ (divId "a1" $ text "One") (divId "a2" $ text "Two")+          prerender_ (divId "b1" $ text "Three") (divId "b2" $ text "Four")+          prerender_ (divId "c1" $ text "Five") (divId "c2" $ text "Six")+    it "works inside other element" $ runWD $ do+      testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do+        el "div" $ prerender_ (text "One") (text "Two")+-- TODO re-enable this+--    it "places fences and removes them" $ runWD $ do+--      testWidget'+--        (do+--          scripts <- WD.findElems $ WD.ByTag "script"+--          filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts+--        )+--        (traverse_ elementShouldBeRemoved)+--        (el "span" $ prerender_ (text "One") (text "Two"))+    it "postBuild works on server side" $ runWD $ do+      lock :: MVar () <- liftIO newEmptyMVar+      testWidget (liftIO $ takeMVar lock) (pure ()) $ do+        prerender_ (do+          pb <- getPostBuild+          performEvent_ $ liftIO (putMVar lock ()) <$ pb) blank+    it "postBuild works on client side" $ runWD $ do+      lock :: MVar () <- liftIO newEmptyMVar+      testWidget (pure ()) (liftIO $ takeMVar lock) $ do+        prerender_ blank $ do+          pb <- getPostBuild+          performEvent_ $ liftIO (putMVar lock ()) <$ pb+    it "result Dynamic is updated *after* switchover" $ runWD $ do+      let static = checkBodyText "PostBuild"+          check = checkBodyText "Client"+      testWidget static check $ void $ do+        d <- prerender (pure "Initial") (pure "Client")+        pb <- getPostBuild+        initial <- sample $ current d+        textNode $ TextNodeConfig initial $ Just $ leftmost [updated d, "PostBuild" <$ pb]+    -- 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+        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"+          check = checkBodyText "Client"+      testWidget static check $ void $ do+        (e, trigger) <- newTriggerEvent+        prerender_ (pure ()) (liftIO $ trigger "Client")+        textNode $ TextNodeConfig "Initial" $ Just e++  describe "runWithReplace" $ session' $ do+    it "works" $ runWD $ do+      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+            shouldContainText "two" ssr+            liftIO $ writeChan replaceChan "three"+            elementShouldBeRemoved ssr+            shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")+      testWidget' setup check $ do+        replace <- triggerEventWithChan replaceChan+        pb <- getPostBuild+        void $ runWithReplace (el "div" $ text "one") $ leftmost+          [ el "div" (text "two") <$ pb+          , el "span" . text <$> replace+          ]+    it "can be nested in initial widget" $ runWD $ do+      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+            shouldContainText "two" ssr+            liftIO $ writeChan replaceChan "three"+            elementShouldBeRemoved ssr+            shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")+      testWidget' setup check $ void $ flip runWithReplace never $ do+        replace <- triggerEventWithChan replaceChan+        pb <- getPostBuild+        void $ runWithReplace (el "div" $ text "one") $ leftmost+          [ el "div" (text "two") <$ pb+          , el "span" . text <$> replace+          ]+    it "can be nested in postBuild widget" $ runWD $ do+      replaceChan <- liftIO newChan+      let setup = findElemWithRetry $ WD.ByTag "div"+          check ssr = do+            -- Check that the original element still exists and has the correct text+            shouldContainText "two" ssr+            liftIO $ writeChan replaceChan "three"+            elementShouldBeRemoved ssr+            shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")+      testWidget' setup check $ void $ do+        pb <- getPostBuild+        runWithReplace (pure ()) $ ffor pb $ \() -> do+          replace <- triggerEventWithChan replaceChan+          pb' <- getPostBuild+          void $ runWithReplace (el "div" $ text "one") $ leftmost+            [ el "div" (text "two") <$ pb'+            , el "span" . text <$> replace+            ]+    it "postBuild works in replaced widget" $ runWD $ do+      replaceChan <- liftIO newChan+      pbLock <- liftIO newEmptyMVar+      let check = liftIO $ do+            writeChan replaceChan ()+            takeMVar pbLock+      testWidget (pure ()) check $ void $ do+        replace <- triggerEventWithChan replaceChan+        runWithReplace (pure ()) $ ffor replace $ \() -> do+          pb <- getPostBuild+          performEvent_ $ liftIO (putMVar pbLock ()) <$ pb+    it "can be nested in event widget" $ runWD $ do+      replaceChan1 :: Chan Text <- liftIO newChan+      replaceChan2 :: Chan Text <- liftIO newChan+      lock :: MVar () <- liftIO newEmptyMVar+      let check = do+            shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")+            liftIO $ do+              writeChan replaceChan1 "one"+              takeMVar lock+            one <- findElemWithRetry $ WD.ByTag "div"+            shouldContainText "pb" one+            liftIO $ writeChan replaceChan2 "two"+            elementShouldBeRemoved one+            shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")+      testWidget (pure ()) check $ void $ do+        replace1 <- triggerEventWithChan replaceChan1+        runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do+          replace2 <- triggerEventWithChan replaceChan2+          pb <- getPostBuild+          performEvent_ $ liftIO (putMVar lock ()) <$ pb+          void $ runWithReplace (el "div" $ text r1) $ leftmost+            [ el "span" . text <$> replace2+            , el "div" (text "pb") <$ pb+            ]+    it "prerender works in replaced widget" $ runWD $ do+      replaceChan <- liftIO newChan+      lock :: MVar () <- liftIO newEmptyMVar+      pbLock :: MVar () <- liftIO newEmptyMVar+      let check = do+            liftIO $ do+              writeChan replaceChan ()+              takeMVar lock+              takeMVar pbLock+      testWidget (pure ()) check $ void $ do+        replace <- triggerEventWithChan replaceChan+        runWithReplace (pure ()) $ ffor replace $ \() -> do+          prerender_ (pure ()) $ do+            liftIO $ putMVar lock ()+            pb <- getPostBuild+            performEvent_ $ liftIO (putMVar pbLock ()) <$ pb+    it "prerender returns in immediate mode" $ runWD $ do+      replaceChan <- liftIO newChan+      pbLock <- liftIO newEmptyMVar+      let check = liftIO $ do+            writeChan replaceChan ()+            takeMVar pbLock+      testWidget (pure ()) check $ void $ do+        replace <- triggerEventWithChan replaceChan+        runWithReplace (pure ()) $ ffor replace $ \() -> do+          prerender_ (pure ()) (pure ())+          liftIO $ putMVar pbLock ()+    it "works in immediate mode (RHS of prerender)" $ runWD $ do+      replaceChan :: Chan Text <- liftIO newChan+      let check = do+            checkBodyText "one"+            one <- findElemWithRetry $ WD.ByTag "div"+            shouldContainText "one" one+            liftIO $ writeChan replaceChan "pb"+            elementShouldBeRemoved one+            shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")+      testWidget (pure ()) check $ void $ do+        replace <- triggerEventWithChan replaceChan+        prerender_ blank $ do+          void $ runWithReplace (el "div" $ text "one") $ el "span" . text <$> replace+    it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do+      replaceChan :: Chan Text <- liftIO newChan+      let check = do+            checkBodyText "two"+            two <- findElemWithRetry $ WD.ByTag "div"+            shouldContainText "two" two+            liftIO $ writeChan replaceChan "three"+            elementShouldBeRemoved two+            shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")+      testWidget (pure ()) check $ void $ do+        replace <- triggerEventWithChan replaceChan+        prerender_ blank $ do+          pb <- getPostBuild+          void $ runWithReplace (el "div" $ text "one") $ leftmost+            [ el "div" (text "two") <$ pb+            , el "span" . text <$> replace+            ]++  describe "traverseDMapWithKeyWithAdjust" $ session' $ do+    let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)+        widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do+          elClass "span" "key" $ text $ textKey k+          elClass "span" "value" $ text $ T.pack $ has @Show k $ show v+          pure (Identity v)+        checkItem :: WD.Element -> Text -> Text -> WD ()+        checkItem li k v = do+          putStrLnDebug "checkItem"+          shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")+          shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")+        checkInitialItems dm xs = do+          putStrLnDebug "checkInitialItems"+          liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)+          forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)+        getAndCheckInitialItems dm = withRetry $ do+          putStrLnDebug "getAndCheckInitialItems"+          xs <- WD.findElems (WD.ByTag "li")+          checkInitialItems dm xs+          pure xs+        checkRemoval chan k = do+          putStrLnDebug "checkRemoval"+          e <- findElemWithRetry (WD.ById $ textKey k)+          liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)+          elementShouldBeRemoved e+        checkReplace chan k v = do+          putStrLnDebug "checkReplace"+          e <- findElemWithRetry (WD.ById $ textKey k)+          liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)+          elementShouldBeRemoved e+          e' <- findElemWithRetry $ WD.ById $ textKey k+          checkItem e' (textKey k) (T.pack $ show v)+        checkInsert chan k v = do+          putStrLnDebug "checkInsert"+          liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)+          e <- findElemWithRetry (WD.ById $ textKey k)+          checkItem e (textKey k) (T.pack $ show v)+        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+          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+        (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+          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+        pb <- getPostBuild+        replace <- triggerEventWithChan chan+        (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]+        liftIO $ dmap `H.shouldBe` keyMap+    it "can delete/update/insert when built in prerender" $ runWD $ do+      chan <- liftIO newChan+      let check = do+            _ <- getAndCheckInitialItems keyMap+            checkRemoval chan Key_Int+            checkReplace chan Key_Char 'B'+            checkInsert chan Key_Bool True+      testWidget (pure ()) check $ do+        replace <- triggerEventWithChan chan+        prerender_ (pure ()) $ do+          (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap replace+          liftIO $ dmap `H.shouldBe` keyMap+    it "can delete/update/insert when built in immediate mode" $ runWD $ do+      chan <- liftIO newChan+      let check = do+            _ <- getAndCheckInitialItems keyMap+            checkRemoval chan Key_Int+            checkReplace chan Key_Char 'B'+            checkInsert chan Key_Bool True+      testWidget (pure ()) check $ void $ do+        pb <- getPostBuild+        runWithReplace (pure ()) $ ffor pb $ \() -> void $ do+          (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan+          liftIO $ dmap `H.shouldBe` keyMap+    -- Should be fixed by prerender changes!+    it "handles postBuild correctly in prerender" $ runWD $ do+      chan <- liftIO newChan+      let check = do+            _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap+            checkRemoval chan Key_Int+            checkInsert chan Key_Char 'B'+            checkReplace chan Key_Bool True+      testWidget (pure ()) check $ do+        replace <- triggerEventWithChan chan+        prerender_ (pure ()) $ void $ do+          pb <- getPostBuild+          (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]+          liftIO $ dmap `H.shouldBe` keyMap++  describe "traverseIntMapWithKeyWithAdjust" $ session' $ do+    let textKeyInt k = "key" <> T.pack (show k)+        intMap = IntMap.fromList+          [ (1, "one")+          , (2, "two")+          , (3, "three")+          ]+    let widget :: DomBuilder t m => IntMap.Key -> Text -> m Text+        widget k v = elAttr "li" ("id" =: textKeyInt k) $ do+          elClass "span" "key" $ text $ textKeyInt k+          elClass "span" "value" $ text v+          pure v+        checkItem :: WD.Element -> Text -> Text -> WD ()+        checkItem li k v = do+          putStrLnDebug "checkItem"+          shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")+          shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")+        checkInitialItems dm xs = do+          putStrLnDebug "checkInitialItems"+          liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)+          forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v+        getAndCheckInitialItems dm = withRetry $ do+          putStrLnDebug "getAndCheckInitialItems"+          xs <- WD.findElems (WD.ByTag "li")+          checkInitialItems dm xs+          pure xs+        checkRemoval chan k = do+          putStrLnDebug "checkRemoval"+          e <- findElemWithRetry (WD.ById $ textKeyInt k)+          liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing+          elementShouldBeRemoved e+        checkReplace chan k v = do+          putStrLnDebug "checkReplace"+          e <- findElemWithRetry (WD.ById $ textKeyInt k)+          liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v+          elementShouldBeRemoved e+          e' <- findElemWithRetry (WD.ById $ textKeyInt k)+          withRetry $ checkItem e' (textKeyInt k) v+        checkInsert chan k v = do+          putStrLnDebug "checkInsert"+          liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v+          e <- findElemWithRetry (WD.ById $ textKeyInt k)+          checkItem e (textKeyInt k) v+        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+          check xs = do+            checkInitialItems intMap xs+            checkRemoval chan 1+            checkReplace chan 2 "deux"+            checkInsert chan 4 "four"+      testWidget' static 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+          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+        pb <- getPostBuild+        replace <- triggerEventWithChan chan+        (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]+        liftIO $ dmap `H.shouldBe` intMap+    xit "can delete/update/insert when built in prerender" $ runWD $ do+      chan <- liftIO newChan+      let check = do+            _ <- getAndCheckInitialItems intMap+            checkRemoval chan 1+            checkReplace chan 2 "deux"+            checkInsert chan 4 "quatre"+      testWidget (pure ()) check $ do+        replace <- triggerEventWithChan chan+        prerender_ (pure ()) $ do+          (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace+          liftIO $ dmap `H.shouldBe` intMap+    xit "can delete/update/insert when built in immediate mode" $ runWD $ do+      chan <- liftIO newChan+      let check = do+            _ <- getAndCheckInitialItems intMap+            checkRemoval chan 1+            checkReplace chan 2 "deux"+            checkInsert chan 4 "quatre"+      testWidget (pure ()) check $ void $ do+        pb <- getPostBuild+        runWithReplace (pure ()) $ ffor pb $ \() -> void $ do+          (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan+          liftIO $ dmap `H.shouldBe` intMap+    -- Should be fixed by prerender changes!+    xit "handles postBuild correctly in prerender" $ runWD $ do+      chan <- liftIO newChan+      let check = do+            _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap+            checkRemoval chan 1+            checkInsert chan 2 "deux"+            checkReplace chan 3 "trois"+      testWidget (pure ()) check $ do+        replace <- triggerEventWithChan chan+        prerender_ (pure ()) $ void $ do+          pb <- getPostBuild+          (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]+          liftIO $ dmap `H.shouldBe` intMap++  describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do+    let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)+        widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do+          elClass "span" "key" $ text $ textKey2 k+          elClass "span" "value" $ text $ T.pack $ has @Show k $ show v+          pure (Identity v)+        textKey2 :: Key2 a -> Text+        textKey2 = \case+          Key2_Int i -> "i" <> T.pack (show i)+          Key2_Char c -> "c" <> T.pack [c]+        checkItem :: WD.Element -> Text -> Text -> WD ()+        checkItem li k v = do+          shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")+          shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")+        checkInitialItems dm xs = do+          liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)+          forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)+        getAndCheckInitialItems dm = withRetry $ do+          xs <- WD.findElems (WD.ByTag "li")+          checkInitialItems dm xs+          pure xs+        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+            liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2)+            shouldContainText (T.strip $ T.unlines ["i11","i22","i33"]) body+          it "can delete an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3]) $ \body chan -> do+            shouldContainText (T.strip $ T.unlines ["i11","i22","i33"]) body+            liftIO $ writeChan chan (deleteDMapKey (Key2_Int 2))+            shouldContainText (T.strip $ T.unlines ["i11","i33"]) body+          it "can swap items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do+            shouldContainText (T.strip $ T.unlines ["i11","i22","i33","i44"]) body+            liftIO $ writeChan chan (swapDMapKey (Key2_Int 2) (Key2_Int 3))+            shouldContainText (T.strip $ T.unlines ["i11","i33","i22","i44"]) body+-- TODO re-enable this+--          it "can move items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do+--            shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body+--            liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))+--            shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body+--            liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete+--            shouldContainText (T.strip $ T.unlines ["i11","i44"]) body+--            liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too+--            shouldContainText (T.strip $ T.unlines ["i11","i44"]) body+--            liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2) -- this step will fail if the above caused an exception, thus works as a proxy for detecting the exception given we can't catch it+--            shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body++    describe "hydration" $ moveSpec $ \initMap test -> do+      chan <- liftIO newChan+      let static = getAndCheckInitialItems initMap+          check xs = do+            checkInitialItems initMap xs+            body <- getBody+            test body chan+      testWidget' static 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+      let check = do+            liftIO $ do+              writeChan replace ()+              takeMVar lock+            xs <- getAndCheckInitialItems initMap+            checkInitialItems initMap xs+            body <- getBody+            test body chan+      testWidget (pure ()) check $ void $ do+        e <- triggerEventWithChan replace+        runWithReplace (pure ()) $ ffor e $ \() -> void $ do+          pb <- getPostBuild+          performEvent_ $ liftIO (putMVar lock ()) <$ pb+          (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan+          liftIO $ assertEqual "DMap" initMap dmap++  describe "hydrating invalid HTML" $ session' $ do+    it "can hydrate list in paragraph" $ runWD $ do+      let static = do+            checkBodyText "before\ninner\nafter"+            -- Two <p> tags should be present+            [p1, p2] <- WD.findElems (WD.ByTag "p")+            ol <- findElemWithRetry (WD.ByTag "ol")+            shouldContainText "before" p1+            shouldContainText "inner" ol+            shouldContainText "" p2+            pure (p1, ol, p2)+          check (p1, ol, p2) = do+            checkBodyText "before\ninner\nafter"+            shouldContainText "before\ninner\nafter" p1+            elementShouldBeRemoved ol+            elementShouldBeRemoved p2+      testWidget' static 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+          text "before"+          el "ol" $ text "inner"+          text "after"++data Selenium = Selenium+  { _selenium_portNumber :: PortNumber+  , _selenium_stopServer :: IO ()+  }++startSeleniumServer :: PortNumber -> IO (IO ())+startSeleniumServer port = do+  (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])+    { std_in = NoStream+    , std_out = NoStream+    , std_err = NoStream+    }+  return $ terminateProcess ph++withSeleniumServer :: (Selenium -> IO ()) -> IO ()+withSeleniumServer f = do+  stopServer <- startSeleniumServer seleniumPort+  threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on+  f $ Selenium+    { _selenium_portNumber = seleniumPort+    , _selenium_stopServer = stopServer+    }++triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender js t m) => Chan a -> m (Event t a)+triggerEventWithChan chan = do+  (e, trigger) <- newTriggerEvent+  -- In prerender because we only want to do this on the client+  prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan+  pure e++shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()+shouldBeWithRetryM m expected = withRetry $ do+  got <- m+  got `shouldBe` expected++assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()+assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k++elementShouldBeRemoved :: WD.Element -> WD ()+elementShouldBeRemoved e = withRetry $ do+  try (WD.getText e) >>= \case+    Left (WD.FailedCommand WD.StaleElementReference _) -> return ()+    Left err -> throwM err+    Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"++shouldContainText :: Text -> WD.Element -> WD ()+shouldContainText t = withRetry . shouldContainTextNoRetry t++shouldContainTextNoRetry :: Text -> WD.Element -> WD ()+shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText++checkBodyText :: Text -> WD ()+checkBodyText = checkTextInTag "body"++checkTextInTag :: Text -> Text -> WD ()+checkTextInTag t expected = do+  e <- findElemWithRetry (WD.ByTag t)+  shouldContainText expected e++checkTextInId :: Text -> Text -> WD ()+checkTextInId i expected = do+  e <- findElemWithRetry (WD.ById i)+  shouldContainText expected e++findElemWithRetry :: Selector -> WD WD.Element+findElemWithRetry = withRetry . WD.findElem++getBody :: WD WD.Element+getBody = WD.findElem $ WD.ByTag "body"++withRetry :: forall a. WD a -> WD a+withRetry a = wait 300+  where wait :: Int -> WD a+        wait 0 = a+        wait n = try a >>= \case+          Left (_ :: SomeException) -> do+            liftIO $ threadDelay 100000+            wait $ n - 1+          Right v -> return v++divId :: DomBuilder t m => Text -> m a -> m a+divId i = elAttr "div" ("id" =: i)++type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)++testWidgetStaticDebug+  :: Bool+  -> WD b+  -- ^ Webdriver commands to run before JS runs and after hydration switchover+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())+  -- ^ Widget we are testing+  -> WD b+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w++-- | TODO: do something about JSExceptions not causing tests to fail+testWidgetDebug+  :: Bool+  -> WD ()+  -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)+  -> WD b+  -- ^ Webdriver commands to run after hydration switchover+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())+  -- ^ Widget we are testing+  -> WD b+testWidgetDebug withDebugging beforeJS afterSwitchover =+  testWidgetDebug' withDebugging beforeJS (const afterSwitchover)++-- | TODO: do something about JSExceptions not causing tests to fail+testWidgetDebug'+  :: Bool+  -> WD a+  -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)+  -> (a -> WD b)+  -- ^ Webdriver commands to run after hydration switchover+  -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())+  -- ^ Widget we are testing (contents of body)+  -> WD b+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do+  let putStrLnDebug :: MonadIO m => Text -> m ()+      putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m+      staticApp = do+        el "head" $ pure ()+        el "body" $ do+          bodyWidget+          el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False+  putStrLnDebug "rendering static"+  ((), html) <- liftIO $ renderStatic staticApp+  putStrLnDebug "rendered static"+  waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run+  waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover+  let entryPoint = do+        putStrLnDebug "taking waitBeforeJS"+        liftIO $ takeMVar waitBeforeJS+        let switchOverAction = do+              putStrLnDebug "switchover syncPoint"+              syncPoint+              putStrLnDebug "putting waitUntilSwitchover"+              liftIO $ putMVar waitUntilSwitchover ()+              putStrLnDebug "put waitUntilSwitchover"+        putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"+        mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget+        putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"+        syncPoint+  application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do+    putStrLnDebug "sending response"+    r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html+    putStrLnDebug "sent response"+    return r+  waitJSaddle <- liftIO newEmptyMVar+  let settings = foldr ($) Warp.defaultSettings+        [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort+        , Warp.setBeforeMainLoop $ do+            putStrLnDebug "putting waitJSaddle"+            putMVar waitJSaddle ()+            putStrLnDebug "put waitJSaddle"+        ]+      -- hSilence to get rid of ConnectionClosed logs+      silenceIfDebug = if withDebugging then id else hSilence [stderr]+      jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application+  jsaddleTid <- liftIO jsaddleWarp+  putStrLnDebug "taking waitJSaddle"+  liftIO $ takeMVar waitJSaddle+  putStrLnDebug "opening page"+  WD.openPage $ "http://localhost:" <> show jsaddlePort+  putStrLnDebug "running beforeJS"+  a <- beforeJS+  putStrLnDebug "putting waitBeforeJS"+  liftIO $ putMVar waitBeforeJS ()+  putStrLnDebug "taking waitUntilSwitchover"+  liftIO $ takeMVar waitUntilSwitchover+  putStrLnDebug "running afterSwitchover"+  b <- afterSwitchover a+  putStrLnDebug "killing jsaddle thread"+  liftIO $ killThread jsaddleTid+  return b++data Key2 a where+  Key2_Int :: Int -> Key2 Int+  Key2_Char :: Char -> Key2 Char++deriveGEq ''Key2+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 _) = (==)