63c5fcd · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Refactor 'ImmediateDomBuilderT' to use 'TriggerEventT'

63c5fcdWill Fancher10 years ago

reflex-dom-core/src/Foreign/JavaScript/Orphans.hs+8−4

compare with develop

unifiedsplit

@@ -5,13 +5,14 @@ module Foreign.JavaScript.Orphans where

6#ifndef __GHCJS__

8−import Reflex.Host.Class (ReflexHost, HostFrame)

9import Control.Monad.Trans.Class (lift)

8import Control.Monad.Trans.Class (lift)

10−import Reflex.PostBuild.Base (PostBuildT)

9+import GHCJS.DOM.Types (MonadJSM(..))

11−import Reflex.PerformEvent.Base (PerformEventT(..))

12import Reflex.DynamicWriter (DynamicWriterT)

10import Reflex.DynamicWriter (DynamicWriterT)

11+import Reflex.Host.Class (ReflexHost, HostFrame)

12+import Reflex.PerformEvent.Base (PerformEventT(..))

13+import Reflex.PostBuild.Base (PostBuildT)

13import Reflex.Requester.Base (RequesterT)

14import Reflex.Requester.Base (RequesterT)

14−import GHCJS.DOM.Types (MonadJSM(..))

15+import Reflex.TriggerEvent.Base

16instance (MonadJSM m, ReflexHost t) => MonadJSM (PostBuildT t m) where

17instance (MonadJSM m, ReflexHost t) => MonadJSM (PostBuildT t m) where

17 liftJSM' = lift . liftJSM'

18 liftJSM' = lift . liftJSM'

@@ -25,4 +26,7 @@ instance MonadJSM m => MonadJSM (DynamicWriterT t w m) where

25instance MonadJSM m => MonadJSM (RequesterT t request response m) where

26instance MonadJSM m => MonadJSM (RequesterT t request response m) where

26 liftJSM' = lift . liftJSM'

27 liftJSM' = lift . liftJSM'

29+instance MonadJSM m => MonadJSM (TriggerEventT t m) where

30+ liftJSM' = lift . liftJSM'

31+

28#endif

32#endif

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+20−26

@@ -21,7 +21,7 @@

21{-# LANGUAGE TypeOperators #-}

22{-# LANGUAGE UndecidableInstances #-}

23module Reflex.Dom.Builder.Immediate

24− ( TriggerRef (..)

24+ ( EventTriggerRef (..)

25 , ImmediateDomBuilderEnv (..)

26 , ImmediateDomBuilderT (..)

27 , runImmediateDomBuilderT

@@ -140,15 +140,14 @@ import Language.Javascript.JSaddle (call, eval)

140import Reflex.Requester.Base

141import Reflex.Requester.Class

142

143−data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }

144−

145data ImmediateDomBuilderEnv t m

143data ImmediateDomBuilderEnv t m

146 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

144 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

147 , _immediateDomBuilderEnv_parent :: Node

145 , _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.

149 }

147 }

150

148

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)

152

151

153#ifndef __GHCJS__

152#ifndef __GHCJS__

154instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where

153instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where

@@ -160,7 +159,7 @@ instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where

160 primitive = lift . primitive

159 primitive = lift . primitive

161

160

162instance MonadTrans (ImmediateDomBuilderT t) where

161instance MonadTrans (ImmediateDomBuilderT t) where

163− lift = ImmediateDomBuilderT . lift . lift

162+ lift = ImmediateDomBuilderT . lift . lift . lift

164

163

165instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where

164instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where

166 withRenderHook hook (ImmediateDomBuilderT a) = do

165 withRenderHook hook (ImmediateDomBuilderT a) = do

@@ -172,8 +171,12 @@ instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilder

172 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_

171 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_

173

172

174{-# INLINABLE runImmediateDomBuilderT #-}

173{-# INLINABLE runImmediateDomBuilderT #-}

174+runImmediateDomBuilderT

175−runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t m -> m a

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

176−runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do

179+runImmediateDomBuilderT (ImmediateDomBuilderT a) env = flip runTriggerEventT (_immediateDomBuilderEnv_events env) $ do

177 rec (x, req) <- runRequesterT (runReaderT a env) rsp

180 rec (x, req) <- runRequesterT (runReaderT a env) rsp

178 rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm

181 rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm

179 return x

182 return x

@@ -187,7 +190,7 @@ askParent :: Monad m => ImmediateDomBuilderT t m Node

187askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent

190askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent

188

191

189{-# INLINABLE askEvents #-}

192{-# 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])

191askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events

194askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events

192

195

193{-# INLINABLE append #-}

196{-# INLINABLE append #-}

@@ -288,7 +291,7 @@ wrap e cfg = do

288 Propagation_Stop -> withIsEvent en DOM.stopPropagation

291 Propagation_Stop -> withIsEvent en DOM.stopPropagation

289 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation

292 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation

290 mv <- liftJSM k --TODO: Only do this when the event is subscribed

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

292 return $ en :=> EventFilterTriggerRef triggerRef

295 return $ en :=> EventFilterTriggerRef triggerRef

293 es <- do

296 es <- do

294 let h :: GhcjsEventHandler er

297 let h :: GhcjsEventHandler er

@@ -308,7 +311,7 @@ wrap e cfg = do

308 Just v -> liftIO $ do

311 Just v -> liftIO $ do

309 --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

312 --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

310 ref <- newIORef $ Just t

313 ref <- newIORef $ Just t

311− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])

314+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

312 return $ Element es e

315 return $ Element es e

313

316

314{-# INLINABLE makeElement #-}

317{-# INLINABLE makeElement #-}

@@ -591,7 +594,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m

591 return ()

594 return ()

592 return (result0, result')

595 return (result0, result')

593

596

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)

595drawChildUpdate initialEnv child = do

598drawChildUpdate initialEnv child = do

596 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

599 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

597 runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv

600 runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv

@@ -630,20 +633,11 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDo

630

633

631instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where

634instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where

632 {-# INLINABLE newTriggerEvent #-}

635 {-# INLINABLE newTriggerEvent #-}

633− newTriggerEvent = do

636+ newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent

634− (e, t) <- newTriggerEventWithOnComplete

635− return (e, \a -> t a $ return ())

636 {-# INLINABLE newTriggerEventWithOnComplete #-}

637 {-# INLINABLE newTriggerEventWithOnComplete #-}

637− newTriggerEventWithOnComplete = do

638+ newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete

638− events <- askEvents

639− (eResult, reResultTrigger) <- lift newEventWithTriggerRef

640− return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]

641 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

639 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

642− newEventWithLazyTriggerWithOnComplete f = do

640+ newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f

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

647

641

648instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where

642instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where

649 type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m

643 type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m

@@ -1020,7 +1014,7 @@ wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $

1020{-# INLINABLE subscribeDomEvent #-}

1014{-# INLINABLE subscribeDomEvent #-}

1021subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))

1015subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))

1022 -> EventM e event (Maybe a)

1016 -> EventM e event (Maybe a)

1023− -> Chan [DSum (TriggerRef t) TriggerInvocation]

1017+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

1024 -> EventTrigger t a

1018 -> EventTrigger t a

1025 -> JSM (JSM ())

1019 -> JSM (JSM ())

1026subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do

1020subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do

@@ -1028,7 +1022,7 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do

1028 forM_ mv $ \v -> liftIO $ do

1022 forM_ mv $ \v -> liftIO $ do

1029 --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

1023 --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

1030 etr <- newIORef $ Just et

1024 etr <- newIORef $ Just et

1031− writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]

1025+ writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]

1032

1026

1033{-# INLINABLE wrapDomEventMaybe #-}

1027{-# INLINABLE wrapDomEventMaybe #-}

1034wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)

1028wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)

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

@@ -127,7 +127,7 @@ attachWidget' rootElement jsSing w = do

127 liftIO $ processAsyncEvents events fc

128 return (a, fc)

129

130−type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

130+type EventChannel = Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

131

132{-# INLINABLE attachWidget'' #-}

133attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))

@@ -143,7 +143,7 @@ processAsyncEvents :: EventChannel -> FireCommand Spider (SpiderHost Global) ->

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

144 ers <- readChan events

145 _ <- runSpiderHost $ do

146− mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do

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

147 me <- readIORef er

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

149 _ <- fire (catMaybes mes) $ return ()