@@ -21,7 +21,7 @@
2121{-# LANGUAGE TypeOperators #-}
2222{-# LANGUAGE UndecidableInstances #-}
2323module Reflex.Dom.Builder.Immediate
24− ( TriggerRef (..)
24+ ( EventTriggerRef (..)
2525 , ImmediateDomBuilderEnv (..)
2626 , ImmediateDomBuilderT (..)
2727 , runImmediateDomBuilderT
@@ -140,15 +140,14 @@ import Language.Javascript.JSaddle (call, eval)
140140import Reflex.Requester.Base
141141import Reflex.Requester.Class
142142
143−data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
144−
145143data ImmediateDomBuilderEnv t m
146144 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
147145 , _immediateDomBuilderEnv_parent :: Node
148− , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
146+ , _immediateDomBuilderEnv_events :: Chan [DSum (EventTriggerRef t) TriggerInvocation] -- TODO: The same chan needs to be passed to 'TriggerEventT'; this should be factored out.
149147 }
150148
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)
149+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t m) (RequesterT t JSM Identity (TriggerEventT t m)) a }
150+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
152151
153152#ifndef __GHCJS__
154153instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
@@ -160,7 +159,7 @@ instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
160159 primitive = lift . primitive
161160
162161instance MonadTrans (ImmediateDomBuilderT t) where
163− lift = ImmediateDomBuilderT . lift . lift
162+ lift = ImmediateDomBuilderT . lift . lift . lift
164163
165164instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where
166165 withRenderHook hook (ImmediateDomBuilderT a) = do
@@ -172,8 +171,12 @@ instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilder
172171 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
173172
174173{-# INLINABLE runImmediateDomBuilderT #-}
175−runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t m -> m a
176−runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do
174+runImmediateDomBuilderT
175+ :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM m, MonadJSM (Performable m))
176+ => ImmediateDomBuilderT t m a
177+ -> ImmediateDomBuilderEnv t m
178+ -> m a
179+runImmediateDomBuilderT (ImmediateDomBuilderT a) env = flip runTriggerEventT (_immediateDomBuilderEnv_events env) $ do
177180 rec (x, req) <- runRequesterT (runReaderT a env) rsp
178181 rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
179182 return x
@@ -187,7 +190,7 @@ askParent :: Monad m => ImmediateDomBuilderT t m Node
187190askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent
188191
189192{-# INLINABLE askEvents #-}
190−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (TriggerRef t) TriggerInvocation])
193+askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
191194askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
192195
193196{-# INLINABLE append #-}
@@ -288,7 +291,7 @@ wrap e cfg = do
288291 Propagation_Stop -> withIsEvent en DOM.stopPropagation
289292 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
290293 mv <- liftJSM k --TODO: Only do this when the event is subscribed
291− liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
294+ liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
292295 return $ en :=> EventFilterTriggerRef triggerRef
293296 es <- do
294297 let h :: GhcjsEventHandler er
@@ -308,7 +311,7 @@ wrap e cfg = do
308311 Just v -> liftIO $ do
309312 --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
310313 ref <- newIORef $ Just t
311− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
314+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
312315 return $ Element es e
313316
314317{-# INLINABLE makeElement #-}
@@ -591,7 +594,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
591594 return ()
592595 return (result0, result')
593596
594−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)
597+drawChildUpdate :: (MonadJSM m, PerformEvent t m, MonadFix m, MonadJSM (Performable m)) => ImmediateDomBuilderEnv t m -> ImmediateDomBuilderT t m (v' a) -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)
595598drawChildUpdate initialEnv child = do
596599 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
597600 runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv
@@ -630,20 +633,11 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDo
630633
631634instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
632635 {-# INLINABLE newTriggerEvent #-}
633− newTriggerEvent = do
634− (e, t) <- newTriggerEventWithOnComplete
635− return (e, \a -> t a $ return ())
636+ newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
636637 {-# INLINABLE newTriggerEventWithOnComplete #-}
637− newTriggerEventWithOnComplete = do
638− events <- askEvents
639− (eResult, reResultTrigger) <- lift newEventWithTriggerRef
640− return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
638+ newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
641639 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
642− newEventWithLazyTriggerWithOnComplete f = do
643− events <- askEvents
644− lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
645− reResultTrigger <- newIORef $ Just t
646− writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
640+ newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
647641
648642instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
649643 type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
@@ -1020,7 +1014,7 @@ wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $
10201014{-# INLINABLE subscribeDomEvent #-}
10211015subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
10221016 -> EventM e event (Maybe a)
1023− -> Chan [DSum (TriggerRef t) TriggerInvocation]
1017+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
10241018 -> EventTrigger t a
10251019 -> JSM (JSM ())
10261020subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
@@ -1028,7 +1022,7 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
10281022 forM_ mv $ \v -> liftIO $ do
10291023 --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
10301024 etr <- newIORef $ Just et
1031− writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
1025+ writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]
10321026
10331027{-# INLINABLE wrapDomEventMaybe #-}
10341028wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)