@@ -22,7 +22,7 @@
2222{-# LANGUAGE TypeOperators #-}
2323{-# LANGUAGE UndecidableInstances #-}
2424module Reflex.Dom.Builder.Immediate
25− ( TriggerRef (..)
25+ ( EventTriggerRef (..)
2626 , ImmediateDomBuilderEnv (..)
2727 , ImmediateDomBuilderT (..)
2828 , runImmediateDomBuilderT
@@ -87,9 +87,10 @@ import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
8787import Reflex.PerformEvent.Class
8888import Reflex.PostBuild.Class
8989import Reflex.TriggerEvent.Base hiding (askEvents)
90+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
9091import Reflex.TriggerEvent.Class
9192
92−import Control.Concurrent.Chan
93+import Control.Concurrent
9394import Control.Lens hiding (element, ix)
9495import Control.Monad.Exception
9596import Control.Monad.Primitive
@@ -115,6 +116,8 @@ import Data.Some (Some)
115116import qualified Data.Some as Some
116117import Data.Text (Text)
117118import qualified Data.Text as T
119+import qualified GHCJS.DOM as DOM
120+import GHCJS.DOM.RequestAnimationFrameCallback
118121import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)
119122import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
120123import qualified GHCJS.DOM.Element as Element
@@ -142,18 +145,17 @@ import Language.Javascript.JSaddle (call, eval)
142145
143146import Reflex.Requester.Base
144147import Reflex.Requester.Class
145−
146−data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
148+import Foreign.JavaScript.Internal.Utils
147149
148150data ImmediateDomBuilderEnv t
149151 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
150152 , _immediateDomBuilderEnv_parent :: Node
151− , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
152153 , _immediateDomBuilderEnv_unreadyChildren :: IORef Word -- Number of children who still aren't fully rendered
153154 , _immediateDomBuilderEnv_commitAction :: JSM () -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
154155 }
155156
156−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity m) a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
157+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
158+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
157159
158160#ifndef __GHCJS__
159161instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
@@ -165,7 +167,7 @@ instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
165167 primitive = lift . primitive
166168
167169instance MonadTrans (ImmediateDomBuilderT t) where
168− lift = ImmediateDomBuilderT . lift . lift
170+ lift = ImmediateDomBuilderT . lift . lift . lift
169171
170172instance (Reflex t, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where
171173 withRenderHook hook (ImmediateDomBuilderT a) = do
@@ -177,11 +179,34 @@ instance (Reflex t, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) w
177179 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
178180
179181{-# INLINABLE runImmediateDomBuilderT #-}
180−runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t -> m a
181−runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do
182+runImmediateDomBuilderT
183+ :: ( Reflex t
184+ , MonadFix m
185+ , PerformEvent t m
186+ , MonadReflexCreateTrigger t m
187+ , MonadJSM m
188+ , MonadJSM (Performable m)
189+ , MonadRef m
190+ , Ref m ~ IORef
191+ )
192+ => ImmediateDomBuilderT t m a
193+ -> ImmediateDomBuilderEnv t
194+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
195+ -> m a
196+runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = flip runTriggerEventT eventChan $ do
197+ win <- DOM.currentWindowUnchecked
182198 rec (x, req) <- runRequesterT (runReaderT a env) rsp
183− rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
199+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame win f $
200+ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
184201 return x
202+ where
203+ runInAnimationFrame win f x = do
204+ rec cb <- newRequestAnimationFrameCallbackSync $ \_ -> do
205+ v <- synchronously x
206+ _ <- liftIO $ f v
207+ freeRequestAnimationFrameCallback cb
208+ _ <- Window.requestAnimationFrame win $ Just cb
209+ return ()
185210
186211{-# INLINABLE askDocument #-}
187212askDocument :: Monad m => ImmediateDomBuilderT t m Document
@@ -192,8 +217,8 @@ askParent :: Monad m => ImmediateDomBuilderT t m Node
192217askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent
193218
194219{-# INLINABLE askEvents #-}
195−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (TriggerRef t) TriggerInvocation])
196−askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
220+askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
221+askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents
197222
198223localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
199224localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
@@ -296,7 +321,7 @@ wrap e cfg = do
296321 Propagation_Stop -> withIsEvent en DOM.stopPropagation
297322 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
298323 mv <- liftJSM k --TODO: Only do this when the event is subscribed
299− liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
324+ liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
300325 return $ en :=> EventFilterTriggerRef triggerRef
301326 es <- do
302327 let h :: GhcjsEventHandler er
@@ -316,7 +341,7 @@ wrap e cfg = do
316341 Just v -> liftIO $ do
317342 --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
318343 ref <- newIORef $ Just t
319− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
344+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
320345 return $ Element
321346 { _element_events = es
322347 , _element_raw = e
@@ -723,10 +748,10 @@ hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
723748 , Patch (p k (Constant Int))
724749 )
725750 => (forall vv vv'.
726− (forall a. k a -> vv a -> RequesterT t JSM Identity m (vv' a))
751+ (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))
727752 -> DMap k vv
728753 -> Event t (p k vv)
729− -> RequesterT t JSM Identity m (DMap k vv', Event t (p k vv'))
754+ -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))
730755 ) -- ^ The base monad's traversal
731756 -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
732757 -> (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
@@ -802,7 +827,7 @@ drawChildUpdate :: (MonadIO m, MonadJSM m)
802827 => ImmediateDomBuilderEnv t
803828 -> (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
804829 -> ImmediateDomBuilderT t m (v' a)
805− -> RequesterT t JSM Identity m (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
830+ -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
806831drawChildUpdate initialEnv markReady child = do
807832 childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
808833 unreadyChildren <- liftIO $ newIORef 0
@@ -848,20 +873,11 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDo
848873
849874instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
850875 {-# INLINABLE newTriggerEvent #-}
851− newTriggerEvent = do
852− (e, t) <- newTriggerEventWithOnComplete
853− return (e, \a -> t a $ return ())
876+ newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
854877 {-# INLINABLE newTriggerEventWithOnComplete #-}
855− newTriggerEventWithOnComplete = do
856− events <- askEvents
857− (eResult, reResultTrigger) <- lift newEventWithTriggerRef
858− return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
878+ newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
859879 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
860− newEventWithLazyTriggerWithOnComplete f = do
861− events <- askEvents
862− lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
863− reResultTrigger <- newIORef $ Just t
864− writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
880+ newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
865881
866882instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
867883 type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
@@ -1238,7 +1254,7 @@ wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $
12381254{-# INLINABLE subscribeDomEvent #-}
12391255subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
12401256 -> EventM e event (Maybe a)
1241− -> Chan [DSum (TriggerRef t) TriggerInvocation]
1257+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
12421258 -> EventTrigger t a
12431259 -> JSM (JSM ())
12441260subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
@@ -1246,7 +1262,7 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
12461262 forM_ mv $ \v -> liftIO $ do
12471263 --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
12481264 etr <- newIORef $ Just et
1249− writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
1265+ writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]
12501266
12511267{-# INLINABLE wrapDomEventMaybe #-}
12521268wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)