git.iko.soy/reflex-dom
on develop help sign in
Add DomRenderHook
b372167Ali Abrar
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+16
compare with develop
unifiedsplit
@@ -6,6 +6,7 @@
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE OverloadedStrings #-}
12{-# LANGUAGE OverloadedStrings #-}
@@ -13,6 +14,7 @@
13{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RecursiveDo #-}
15{-# LANGUAGE RecursiveDo #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE StandaloneDeriving #-}
16#ifdef USE_TEMPLATE_HASKELL
18#ifdef USE_TEMPLATE_HASKELL
17{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE TemplateHaskell #-}
18#endif
20#endif
@@ -50,6 +52,7 @@ import Data.String
50import Data.Text (Text)
52import Data.Text (Text)
51import Data.Type.Coercion
53import Data.Type.Coercion
52import GHC.Exts (Constraint)
54import GHC.Exts (Constraint)
55+import GHCJS.DOM.Types (JSM)
53
56
54class Default (EventSpec d EventResult) => DomSpace d where
57class Default (EventSpec d EventResult) => DomSpace d where
55 type EventSpec d :: (EventTag -> *) -> *
58 type EventSpec d :: (EventTag -> *) -> *
@@ -669,3 +672,16 @@ liftTextAreaElement cfg = liftWithStateless $ \run -> textAreaElement $ fmap1 ru
669
672
670liftWrapRawElement :: LiftDomBuilder t f m => RawElement (DomBuilderSpace m) -> RawElementConfig er t (f m) -> f m (Element er (DomBuilderSpace m) t)
673liftWrapRawElement :: LiftDomBuilder t f m => RawElement (DomBuilderSpace m) -> RawElementConfig er t (f m) -> f m (Element er (DomBuilderSpace m) t)
671liftWrapRawElement e es = liftWithStateless $ \run -> wrapRawElement e $ fmap1 run es
674liftWrapRawElement e es = liftWithStateless $ \run -> wrapRawElement e $ fmap1 run es
675+
676+class Monad m => DomRenderHook m where
677+ withRenderHook :: (forall x. JSM x -> JSM x) -> m a -> m a
678+
679+instance DomRenderHook m => DomRenderHook (ReaderT e m) where
680+ withRenderHook hook (ReaderT a) = ReaderT $ \e -> withRenderHook hook $ a e
681+
682+instance DomRenderHook m => DomRenderHook (StateT e m) where
683+ withRenderHook hook (StateT a) = StateT $ \s -> withRenderHook hook $ a s
684+
685+deriving instance DomRenderHook m => DomRenderHook (EventWriterT t w m)
686+deriving instance DomRenderHook m => DomRenderHook (RequesterT t req rsp m)
687+deriving instance DomRenderHook m => DomRenderHook (PostBuildT t m)
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+108−53
@@ -13,13 +13,70 @@
13{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RecursiveDo #-}
14{-# LANGUAGE RecursiveDo #-}
15{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16+{-# LANGUAGE StandaloneDeriving #-}
16#ifdef USE_TEMPLATE_HASKELL
17#ifdef USE_TEMPLATE_HASKELL
17{-# LANGUAGE TemplateHaskell #-}
18{-# LANGUAGE TemplateHaskell #-}
18#endif
19#endif
19{-# LANGUAGE TypeFamilies #-}
20{-# LANGUAGE TypeFamilies #-}
20{-# LANGUAGE TypeOperators #-}
21{-# LANGUAGE TypeOperators #-}
21{-# LANGUAGE UndecidableInstances #-}
22{-# LANGUAGE UndecidableInstances #-}
22−module Reflex.Dom.Builder.Immediate where
23+module Reflex.Dom.Builder.Immediate
24+ ( TriggerRef (..)
25+ , ImmediateDomBuilderEnv (..)
26+ , ImmediateDomBuilderT (..)
27+ , runImmediateDomBuilderT
28+ , askDocument
29+ , askParent
30+ , askEvents
31+ , append
32+ , textNodeInternal
33+ , deleteBetweenExclusive
34+ , extractBetweenExclusive
35+ , deleteUpTo
36+ , extractUpTo
37+ , SupportsImmediateDomBuilder
38+ , collectUpTo
39+ , collectUpToGivenParent
40+ , EventFilterTriggerRef (..)
41+ , wrap
42+ , makeElement
43+ , GhcjsDomHandler (..)
44+ , GhcjsDomHandler1 (..)
45+ , GhcjsDomEvent (..)
46+ , GhcjsDomSpace
47+ , GhcjsEventFilter (..)
48+ , Pair1 (..)
49+ , Maybe1 (..)
50+ , GhcjsEventSpec (..)
51+ , GhcjsEventHandler (..)
52+#ifndef USE_TEMPLATE_HASKELL
53+ , phantom2
54+ , ghcjsEventSpec_filters
55+ , ghcjsEventSpec_handler
56+#endif
57+ , drawChildUpdate
58+ , mkHasFocus
59+ , insertBefore
60+ , EventType
61+ , defaultDomEventHandler
62+ , defaultDomWindowEventHandler
63+ , withIsEvent
64+ , showEventName
65+ , elementOnEventName
66+ , windowOnEventName
67+ , wrapDomEvent
68+ , subscribeDomEvent
69+ , wrapDomEventMaybe
70+ , wrapDomEventsMaybe
71+ , getKeyEvent
72+ , getMouseEventCoords
73+ , getTouchEvent
74+ , WindowConfig (..)
75+ , Window (..)
76+ , wrapWindow
77+ , ghcjsEventSpec_filters
78+ , ghcjsEventSpec_handler
79+ ) where
23
80
24import Foreign.JavaScript.TH
81import Foreign.JavaScript.TH
25import Reflex.Class as Reflex
82import Reflex.Class as Reflex
@@ -37,7 +94,6 @@ import Control.Monad.Exception
37import Control.Monad.Primitive
94import Control.Monad.Primitive
38import Control.Monad.Reader
95import Control.Monad.Reader
39import Control.Monad.Ref
96import Control.Monad.Ref
40−import Control.Monad.Trans.Control
41#ifndef USE_TEMPLATE_HASKELL
97#ifndef USE_TEMPLATE_HASKELL
42import Data.Functor.Contravariant (phantom)
98import Data.Functor.Contravariant (phantom)
43#endif
99#endif
@@ -81,15 +137,18 @@ import GHCJS.DOM.UIEvent
81import qualified GHCJS.DOM.Window as Window
137import qualified GHCJS.DOM.Window as Window
82import Language.Javascript.JSaddle (call, eval)
138import Language.Javascript.JSaddle (call, eval)
83
139
140+import Reflex.Requester.Base
141+import Reflex.Requester.Class
142+
84data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
143data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
85
144
86−data ImmediateDomBuilderEnv t
145+data ImmediateDomBuilderEnv t m
87 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
146 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
88 , _immediateDomBuilderEnv_parent :: Node
147 , _immediateDomBuilderEnv_parent :: Node
89 , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
148 , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
90 }
149 }
91
150
92−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
151+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t m) (RequesterT t JSM Identity m) a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
93
152
94#ifndef __GHCJS__
153#ifndef __GHCJS__
95instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
154instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
@@ -100,17 +159,28 @@ instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
100 type PrimState (ImmediateDomBuilderT x m) = PrimState m
159 type PrimState (ImmediateDomBuilderT x m) = PrimState m
101 primitive = lift . primitive
160 primitive = lift . primitive
102
161
103−instance MonadTransControl (ImmediateDomBuilderT t) where
104− type StT (ImmediateDomBuilderT t) a = StT (ReaderT (ImmediateDomBuilderEnv t)) a
105− liftWith = defaultLiftWith ImmediateDomBuilderT unImmediateDomBuilderT
106− restoreT = defaultRestoreT ImmediateDomBuilderT
107−
108instance MonadTrans (ImmediateDomBuilderT t) where
162instance MonadTrans (ImmediateDomBuilderT t) where
109− lift = ImmediateDomBuilderT . lift
163+ lift = ImmediateDomBuilderT . lift . lift
164+
165+instance (PerformEvent t m, PrimMonad m) => DomRenderHook (ImmediateDomBuilderT t m) where
166+ withRenderHook hook (ImmediateDomBuilderT a) = do
167+ e <- ImmediateDomBuilderT ask
168+ ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
169+ (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp
170+ return (ffor req $ \rm -> hook $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm, x)
171+
172+requestDomAction :: (Reflex t, Monad m, PrimMonad m) => Event t (JSM a) -> ImmediateDomBuilderT t m (Event t a)
173+requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity
174+
175+requestDomAction_ :: (Reflex t, Monad m, PrimMonad m) => Event t (JSM a) -> ImmediateDomBuilderT t m ()
176+requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
110
177
111{-# INLINABLE runImmediateDomBuilderT #-}
178{-# INLINABLE runImmediateDomBuilderT #-}
112−runImmediateDomBuilderT :: ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t -> m a
179+runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t m -> m a
113−runImmediateDomBuilderT (ImmediateDomBuilderT a) = runReaderT a
180+runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do
181+ rec (x, req) <- runRequesterT (runReaderT a env) rsp
182+ rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
183+ return x
114
184
115{-# INLINABLE askDocument #-}
185{-# INLINABLE askDocument #-}
116askDocument :: Monad m => ImmediateDomBuilderT t m Document
186askDocument :: Monad m => ImmediateDomBuilderT t m Document
@@ -187,7 +257,7 @@ extractUpTo df s e = liftJSM $ do
187 ]
257 ]
188 void $ call f f (df, s, e)
258 void $ call f f (df, s, e)
189
259
190−type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m)
260+type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m, PrimMonad m)
191
261
192{-# INLINABLE collectUpTo #-}
262{-# INLINABLE collectUpTo #-}
193collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
263collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
@@ -208,7 +278,7 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR
208wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
278wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
209wrap e cfg = do
279wrap e cfg = do
210 events <- askEvents
280 events <- askEvents
211− mapM_ (performEvent_ . fmap (imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
281+ mapM_ (requestDomAction_ . fmap (imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
212 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
282 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
213 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv)) (_rawElementConfig_modifyAttributes cfg)
283 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv)) (_rawElementConfig_modifyAttributes cfg)
214 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
284 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
@@ -249,17 +319,15 @@ wrap e cfg = do
249makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
319makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
250makeElement elementTag cfg child = do
320makeElement elementTag cfg child = do
251 doc <- askDocument
321 doc <- askDocument
252− events <- askEvents
322+ env <- ImmediateDomBuilderT ask
253 e <- liftJSM $ case cfg ^. namespace of
323 e <- liftJSM $ case cfg ^. namespace of
254 Nothing -> createElementUnchecked doc (Just elementTag)
324 Nothing -> createElementUnchecked doc (Just elementTag)
255 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
325 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
256 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
326 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
257 Nothing -> lift $ setAttribute e n v
327 Nothing -> lift $ setAttribute e n v
258 Just ans -> lift $ setAttributeNS e (Just ans) n v
328 Just ans -> lift $ setAttributeNS e (Just ans) n v
259− result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
329+ result <- ImmediateDomBuilderT $ lift $ runReaderT (unImmediateDomBuilderT child) $ env
260 { _immediateDomBuilderEnv_parent = toNode e
330 { _immediateDomBuilderEnv_parent = toNode e
261− , _immediateDomBuilderEnv_document = doc
262− , _immediateDomBuilderEnv_events = events
263 }
331 }
264 append e
332 append e
265 wrapped <- wrap e $ extractRawElementConfig cfg
333 wrapped <- wrap e $ extractRawElementConfig cfg
@@ -335,7 +403,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
335 {-# INLINABLE textNode #-}
403 {-# INLINABLE textNode #-}
336 textNode (TextNodeConfig initialContents mSetContents) = do
404 textNode (TextNodeConfig initialContents mSetContents) = do
337 n <- textNodeInternal initialContents
405 n <- textNodeInternal initialContents
338− mapM_ (lift . performEvent_ . fmap (setNodeValue n . Just)) mSetContents
406+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
339 return $ TextNode n
407 return $ TextNode n
340 {-# INLINABLE element #-}
408 {-# INLINABLE element #-}
341 element elementTag cfg child = fst <$> makeElement elementTag cfg child
409 element elementTag cfg child = fst <$> makeElement elementTag cfg child
@@ -346,10 +414,10 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
346 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
414 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
347 v0 <- Input.getValueUnchecked domInputElement
415 v0 <- Input.getValueUnchecked domInputElement
348 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
416 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
349− valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
417+ valueChangedByUI <- performEvent $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
350 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
418 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
351 Nothing -> return never
419 Nothing -> return never
352− Just eSetValue -> performEvent $ ffor eSetValue $ \v' -> do
420+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
353 Input.setValue domInputElement $ Just v'
421 Input.setValue domInputElement $ Just v'
354 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
422 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
355 v <- holdDyn v0 $ leftmost
423 v <- holdDyn v0 $ leftmost
@@ -361,7 +429,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
361 Input.getChecked domInputElement
429 Input.getChecked domInputElement
362 checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
430 checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
363 Nothing -> return never
431 Nothing -> return never
364− Just eNewchecked -> performEvent $ ffor eNewchecked $ \newChecked -> do
432+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
365 oldChecked <- Input.getChecked domInputElement
433 oldChecked <- Input.getChecked domInputElement
366 Input.setChecked domInputElement newChecked
434 Input.setChecked domInputElement newChecked
367 return $ if newChecked /= oldChecked
435 return $ if newChecked /= oldChecked
@@ -397,10 +465,10 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
397 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
465 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
398 v0 <- TextArea.getValueUnchecked domTextAreaElement
466 v0 <- TextArea.getValueUnchecked domTextAreaElement
399 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
467 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
400− valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
468+ valueChangedByUI <- performEvent $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
401 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
469 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
402 Nothing -> return never
470 Nothing -> return never
403− Just eSetValue -> performEvent $ ffor eSetValue $ \v' -> do
471+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
404 TextArea.setValue domTextAreaElement $ Just v'
472 TextArea.setValue domTextAreaElement $ Just v'
405 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
473 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
406 v <- holdDyn v0 $ leftmost
474 v <- holdDyn v0 $ leftmost
@@ -422,10 +490,10 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
422 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
490 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
423 Just v0 <- Select.getValue domSelectElement
491 Just v0 <- Select.getValue domSelectElement
424 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
492 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
425− valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
493+ valueChangedByUI <- performEvent $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
426 valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
494 valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
427 Nothing -> return never
495 Nothing -> return never
428− Just eSetValue -> performEvent $ ffor eSetValue $ \v' -> do
496+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
429 Select.setValue domSelectElement $ Just v'
497 Select.setValue domSelectElement $ Just v'
430 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
498 getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
431 v <- holdDyn v0 $ leftmost
499 v <- holdDyn v0 $ leftmost
@@ -444,7 +512,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
444 placeRawElement = append
512 placeRawElement = append
445 wrapRawElement = wrap
513 wrapRawElement = wrap
446
514
447−instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
515+instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where
448 runWithReplace a0 a' = do
516 runWithReplace a0 a' = do
449 initialEnv <- ImmediateDomBuilderT ask
517 initialEnv <- ImmediateDomBuilderT ask
450 before <- textNodeInternal ("" :: Text)
518 before <- textNodeInternal ("" :: Text)
@@ -454,9 +522,9 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
454 result <- a0
522 result <- a0
455 append after
523 append after
456 return result
524 return result
457− (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
525+ (result0, result') <- ImmediateDomBuilderT $ lift $ runWithReplace (runReaderT (unImmediateDomBuilderT drawInitialChild) initialEnv) $ ffor a' $ \child -> do
458 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
526 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
459− result <- runImmediateDomBuilderT child $ initialEnv
527+ result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
460 { _immediateDomBuilderEnv_parent = toNode df
528 { _immediateDomBuilderEnv_parent = toNode df
461 }
529 }
462 deleteBetweenExclusive before after
530 deleteBetweenExclusive before after
@@ -465,7 +533,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
465 return (result0, result')
533 return (result0, result')
466 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
534 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
467 initialEnv <- ImmediateDomBuilderT ask
535 initialEnv <- ImmediateDomBuilderT ask
468− (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
536+ (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
469 let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
537 let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
470 placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
538 placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
471 result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r
539 result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r
@@ -473,10 +541,10 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
473 placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
541 placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
474 _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
542 _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
475 lastPlaceholder <- textNodeInternal ("" :: Text)
543 lastPlaceholder <- textNodeInternal ("" :: Text)
476− performEvent_ $ flip push children' $ \(PatchDMap p) -> do
544+ requestDomAction_ $ flip push children' $ \(PatchDMap p) -> do
477 phs <- sample placeholders
545 phs <- sample placeholders
478 if DMap.null p then return Nothing else return $ Just $ do
546 if DMap.null p then return Nothing else return $ Just $ do
479− let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> Performable m ()
547+ let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> JSM ()
480 g (k :=> ComposeMaybe mv) = do
548 g (k :=> ComposeMaybe mv) = do
481 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
549 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
482 forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
550 forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
@@ -485,7 +553,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
485 return (result0, result')
553 return (result0, result')
486 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
554 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
487 initialEnv <- ImmediateDomBuilderT ask
555 initialEnv <- ImmediateDomBuilderT ask
488− (children0, children') <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
556+ (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
489 let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
557 let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
490 placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
558 placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
491 result' = ffor children' $ mapPatchDMapWithMove $ \(Compose (_, _, r)) -> r
559 result' = ffor children' $ mapPatchDMapWithMove $ \(Compose (_, _, r)) -> r
@@ -493,11 +561,11 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
493 placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
561 placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
494 _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
562 _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
495 lastPlaceholder <- textNodeInternal ("" :: Text)
563 lastPlaceholder <- textNodeInternal ("" :: Text)
496− performEvent_ $ flip push children' $ \p_ -> do
564+ requestDomAction_ $ flip push children' $ \p_ -> do
497 let p = unPatchDMapWithMove p_
565 let p = unPatchDMapWithMove p_
498 phsBefore <- sample placeholders
566 phsBefore <- sample placeholders
499 if DMap.null p then return Nothing else return $ Just $ do
567 if DMap.null p then return Nothing else return $ Just $ do
500− let collectIfMoved :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> Performable m (Constant (Maybe DOM.DocumentFragment) a)
568+ let collectIfMoved :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
501 collectIfMoved k e = do
569 collectIfMoved k e = do
502 let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
570 let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
503 nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
571 nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
@@ -509,7 +577,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
509 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
577 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
510 collected <- DMap.traverseWithKey collectIfMoved p
578 collected <- DMap.traverseWithKey collectIfMoved p
511 let phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
579 let phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
512− let placeFragment :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> Performable m (Constant () a)
580+ let placeFragment :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant () a)
513 placeFragment k e = do
581 placeFragment k e = do
514 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
582 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
515 case e of
583 case e of
@@ -525,10 +593,12 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
525 return ()
593 return ()
526 return (result0, result')
594 return (result0, result')
527
595
528−drawChildUpdate :: MonadJSM m => ImmediateDomBuilderEnv t -> ImmediateDomBuilderT t m (v' a) -> m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)
596+drawChildUpdate :: (MonadJSM m, PerformEvent t m, MonadFix m, MonadJSM (Performable m)) => ImmediateDomBuilderEnv t m -> ImmediateDomBuilderT t m (v' a) -> RequesterT t JSM Identity m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)
529drawChildUpdate initialEnv child = do
597drawChildUpdate initialEnv child = do
530 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
598 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
599+ runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv
531− runImmediateDomBuilderT (Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv { _immediateDomBuilderEnv_parent = toNode df }
600+ { _immediateDomBuilderEnv_parent = toNode df
601+ }
532
602
533mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
603mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
534mkHasFocus e = do
604mkHasFocus e = do
@@ -538,21 +608,6 @@ mkHasFocus e = do
538 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
608 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
539 ]
609 ]
540
610
541−{-# INLINABLE insertImmediateAbove #-}
542−insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadJSM (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
543−insertImmediateAbove n toInsertAbove = do
544− events <- askEvents
545− lift $ performEvent $ ffor toInsertAbove $ \new -> do
546− doc <- getOwnerDocumentUnchecked n
547− df <- createDocumentFragmentUnchecked doc
548− result <- runImmediateDomBuilderT new $ ImmediateDomBuilderEnv
549− { _immediateDomBuilderEnv_parent = toNode df
550− , _immediateDomBuilderEnv_document = doc
551− , _immediateDomBuilderEnv_events = events
552− }
553− df `insertBefore` n
554− return result
555−
556insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
611insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
557insertBefore new existing = do
612insertBefore new existing = do
558 p <- getParentNodeUnchecked existing
613 p <- getParentNodeUnchecked existing