@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -46,6 +47,10 @@ import GHCJS.DOM.NonElementParentNode
4647import GHCJS.DOM.Types (JSM)
4748import qualified GHCJS.DOM.Types as DOM
4849
50+#ifdef PROFILE_REFLEX
51+import Reflex.Profiled
52+#endif
53+
4954{-# INLINE mainWidget #-}
5055mainWidget :: (forall x. Widget x ()) -> JSM ()
5156mainWidget = mainWidget'
@@ -77,7 +82,27 @@ mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do
7782 body <- getBodyUnchecked doc
7883 attachWidget body jsSing w
7984
80−type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithJSContextSingleton x (PerformEventT Spider (SpiderHost Global)))) --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
85+-- | The Reflex timeline for interacting with the DOM
86+type DomTimeline =
87+#ifdef PROFILE_REFLEX
88+ ProfiledTimeline
89+#endif
90+ Spider
91+
92+-- | The ReflexHost the DOM lives in
93+type DomHost =
94+#ifdef PROFILE_REFLEX
95+ ProfiledM
96+#endif
97+ (SpiderHost Global)
98+
99+runDomHost :: DomHost a -> IO a
100+runDomHost = runSpiderHost
101+#ifdef PROFILE_REFLEX
102+ . runProfiledM
103+#endif
104+
105+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
81106
82107{-# INLINABLE attachWidget #-}
83108attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a
@@ -94,7 +119,7 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
94119 (events, fc) <- liftIO . attachWidget'' $ \events -> do
95120 let (headWidget, bodyWidget) = widgets
96121 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
97− let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c
122+ let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c
98123 go w df = do
99124 unreadyChildren <- liftIO $ newIORef 0
100125 let builderEnv = ImmediateDomBuilderEnv
@@ -118,7 +143,7 @@ replaceElementContents e df = do
118143 return ()
119144
120145{-# INLINABLE attachWidget' #-}
121−attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM (a, FireCommand Spider (SpiderHost Global))
146+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM (a, FireCommand DomTimeline DomHost)
122147attachWidget' rootElement jsSing w = do
123148 doc <- getOwnerDocumentUnchecked rootElement
124149 df <- createDocumentFragment doc
@@ -137,22 +162,22 @@ attachWidget' rootElement jsSing w = do
137162 liftIO $ processAsyncEvents events fc
138163 return (a, fc)
139164
140−type EventChannel = Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
165+type EventChannel = Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
141166
142167{-# INLINABLE attachWidget'' #-}
143−attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))
168+attachWidget'' :: (EventChannel -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))) -> IO (a, FireCommand DomTimeline DomHost)
144169attachWidget'' w = do
145170 events <- newChan
146− runSpiderHost $ do
171+ runDomHost $ do
147172 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events
148173 mPostBuildTrigger <- readRef postBuildTriggerRef
149174 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
150175 return (result, fc)
151176
152−processAsyncEvents :: EventChannel -> FireCommand Spider (SpiderHost Global) -> IO ()
177+processAsyncEvents :: EventChannel -> FireCommand DomTimeline DomHost -> IO ()
153178processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
154179 ers <- readChan events
155− _ <- runSpiderHost $ do
180+ _ <- runDomHost $ do
156181 mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
157182 me <- readIORef er
158183 return $ fmap (\e -> e :=> Identity a) me
@@ -176,7 +201,7 @@ newtype AppOutput t = AppOutput --TODO: Add quit event
176201 { _appOutput_windowConfig :: WindowConfig t
177202 }
178203
179−runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> JSM ()
204+runApp' :: (t ~ DomTimeline) => (forall x. AppInput t -> Widget x (AppOutput t)) -> JSM ()
180205runApp' app = withJSContextSingleton $ \jsSing -> do
181206 doc <- currentDocumentUnchecked
182207 body <- getBodyUnchecked doc