03eeec5 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Add profile-reflex flag

03eeec5Ryan Trinkle9 years ago

reflex-dom-core/reflex-dom-core.cabal+8

compare with develop

unifiedsplit

@@ -33,6 +33,11 @@ flag expose-all-unfoldings

33 default: False

34 manual: True

36+flag profile-reflex

37+ description: Add a layer of profiling to all Reflex events in the system

38+ default: False

39+ manual: True

40+

36library

41library

37 hs-source-dirs: src

42 hs-source-dirs: src

38 build-depends:

43 build-depends:

@@ -123,6 +128,9 @@ library

123 if flag(use-reflex-optimizer)

128 if flag(use-reflex-optimizer)

124 ghc-options: -fplugin=Reflex.Optimizer

129 ghc-options: -fplugin=Reflex.Optimizer

125

130

131+ if flag(profile-reflex)

132+ cpp-options: -DPROFILE_REFLEX

133+

126 if flag(use-template-haskell)

134 if flag(use-template-haskell)

127 build-depends:

135 build-depends:

128 dependent-sum >= 0.3 && < 0.5,

136 dependent-sum >= 0.3 && < 0.5,

reflex-dom-core/src/Reflex/Dom/Main.hs+34−9

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

@@ -46,6 +47,10 @@ import GHCJS.DOM.NonElementParentNode

46import GHCJS.DOM.Types (JSM)

47import GHCJS.DOM.Types (JSM)

47import qualified GHCJS.DOM.Types as DOM

48import qualified GHCJS.DOM.Types as DOM

50+#ifdef PROFILE_REFLEX

51+import Reflex.Profiled

52+#endif

53+

49{-# INLINE mainWidget #-}

54{-# INLINE mainWidget #-}

50mainWidget :: (forall x. Widget x ()) -> JSM ()

55mainWidget :: (forall x. Widget x ()) -> JSM ()

51mainWidget = mainWidget'

56mainWidget = mainWidget'

@@ -77,7 +82,27 @@ mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do

77 body <- getBodyUnchecked doc

82 body <- getBodyUnchecked doc

78 attachWidget body jsSing w

83 attachWidget body jsSing w

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+

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

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

106

82{-# INLINABLE attachWidget #-}

107{-# INLINABLE attachWidget #-}

83attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

108attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

@@ -94,7 +119,7 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do

94 (events, fc) <- liftIO . attachWidget'' $ \events -> do

119 (events, fc) <- liftIO . attachWidget'' $ \events -> do

95 let (headWidget, bodyWidget) = widgets

120 let (headWidget, bodyWidget) = widgets

96 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

121 (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

98 go w df = do

123 go w df = do

99 unreadyChildren <- liftIO $ newIORef 0

124 unreadyChildren <- liftIO $ newIORef 0

100 let builderEnv = ImmediateDomBuilderEnv

125 let builderEnv = ImmediateDomBuilderEnv

@@ -118,7 +143,7 @@ replaceElementContents e df = do

118 return ()

143 return ()

119

144

120{-# INLINABLE attachWidget' #-}

145{-# 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)

122attachWidget' rootElement jsSing w = do

147attachWidget' rootElement jsSing w = do

123 doc <- getOwnerDocumentUnchecked rootElement

148 doc <- getOwnerDocumentUnchecked rootElement

124 df <- createDocumentFragment doc

149 df <- createDocumentFragment doc

@@ -137,22 +162,22 @@ attachWidget' rootElement jsSing w = do

137 liftIO $ processAsyncEvents events fc

162 liftIO $ processAsyncEvents events fc

138 return (a, fc)

163 return (a, fc)

139

164

140−type EventChannel = Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

165+type EventChannel = Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]

141

166

142{-# INLINABLE attachWidget'' #-}

167{-# 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)

144attachWidget'' w = do

169attachWidget'' w = do

145 events <- newChan

170 events <- newChan

146− runSpiderHost $ do

171+ runDomHost $ do

147 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events

172 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events

148 mPostBuildTrigger <- readRef postBuildTriggerRef

173 mPostBuildTrigger <- readRef postBuildTriggerRef

149 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

174 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

150 return (result, fc)

175 return (result, fc)

151

176

152−processAsyncEvents :: EventChannel -> FireCommand Spider (SpiderHost Global) -> IO ()

177+processAsyncEvents :: EventChannel -> FireCommand DomTimeline DomHost -> IO ()

153processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do

178processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do

154 ers <- readChan events

179 ers <- readChan events

155− _ <- runSpiderHost $ do

180+ _ <- runDomHost $ do

156 mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do

181 mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do

157 me <- readIORef er

182 me <- readIORef er

158 return $ fmap (\e -> e :=> Identity a) me

183 return $ fmap (\e -> e :=> Identity a) me

@@ -176,7 +201,7 @@ newtype AppOutput t = AppOutput --TODO: Add quit event

176 { _appOutput_windowConfig :: WindowConfig t

201 { _appOutput_windowConfig :: WindowConfig t

177 }

202 }

178

203

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 ()

180runApp' app = withJSContextSingleton $ \jsSing -> do

205runApp' app = withJSContextSingleton $ \jsSing -> do

181 doc <- currentDocumentUnchecked

206 doc <- currentDocumentUnchecked

182 body <- getBodyUnchecked doc

207 body <- getBodyUnchecked doc