bd678c3 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Change root events to include a free fanout

bd678c3Ryan Trinkle11 years ago

src/Reflex/Host/Class.hs+2

compare with develop

unifiedsplit

@@ -14,6 +14,7 @@ import Control.Monad.Trans.RWS (RWST())

14import Control.Monad.Trans.State (StateT())

15import Data.Dependent.Sum (DSum)

16import Data.Monoid

17+import Data.GADT.Compare

17import Control.Monad.Ref

18import Control.Monad.Ref

19-- Note: this import must come last to silence warnings from AMP

20-- Note: this import must come last to silence warnings from AMP

@@ -50,6 +51,7 @@ class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where

50 --

51 --

51 -- Note: An event may be set up multiple times. So after the teardown action is executed, the event may still be set up again in the future.

52 -- Note: An event may be set up multiple times. So after the teardown action is executed, the event may still be set up again in the future.

52 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)

53 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)

54+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)

54class (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where

56class (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where

55 -- | Propagate some events firings and read the values of events afterwards.

57 -- | Propagate some events firings and read the values of events afterwards.

src/Reflex/Spider/Internal.hs+62−34

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

1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase #-}

1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}

2module Reflex.Spider.Internal where

4import qualified Reflex.Class as R

@@ -109,6 +109,7 @@ data EventEnv

109 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])

110 , eventEnvHoldInits :: !(IORef [SomeHoldInit])

111 , eventEnvClears :: !(IORef [SomeMaybeIORef])

112+ , eventEnvRootClears :: !(IORef [SomeDMapIORef])

112 , eventEnvCurrentHeight :: !(IORef Int)

113 , eventEnvCurrentHeight :: !(IORef Int)

113 , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])

114 , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])

114 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))

115 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))

@@ -138,6 +139,11 @@ scheduleClear r = EventM $ do

138 clears <- asks eventEnvClears

139 clears <- asks eventEnvClears

139 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

140 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

140

141

142+scheduleRootClear :: IORef (DMap k) -> EventM ()

143+scheduleRootClear r = EventM $ do

144+ clears <- asks eventEnvRootClears

145+ liftIO $ modifyIORef' clears (SomeDMapIORef r :)

146+

141scheduleMerge :: Int -> MergeSubscribed a -> EventM ()

147scheduleMerge :: Int -> MergeSubscribed a -> EventM ()

142scheduleMerge height subscribed = EventM $ do

148scheduleMerge height subscribed = EventM $ do

143 delayedRef <- asks eventEnvDelayedMerges

149 delayedRef <- asks eventEnvDelayedMerges

@@ -213,13 +219,13 @@ data Invalidator

213

219

214data RootSubscribed a

220data RootSubscribed a

215 = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])

221 = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])

216− , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence

222+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence

217 }

223 }

218

224

219−data Root a

225+data Root (k :: * -> *)

220− = Root { rootOccurrence :: !(IORef (Maybe a)) -- The currently-firing occurrence of this event

226+ = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event

221− , rootSubscribed :: !(IORef (Maybe (RootSubscribed a)))

227+ , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))

222− , rootInit :: !(RootTrigger a -> IO (IO ()))

228+ , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))

223 }

229 }

224

230

225data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)

231data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)

@@ -365,7 +371,7 @@ showSubscriberType = \case

365 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

371 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

366

372

367data Event a

373data Event a

368− = EventRoot !(Root a)

374+ = forall k. GCompare k => EventRoot !(k a) !(Root k)

369 | EventNever

375 | EventNever

370 | forall b. EventPush !(Push b a)

376 | forall b. EventPush !(Push b a)

371 | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)

377 | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)

@@ -375,7 +381,7 @@ data Event a

375

381

376showEventType :: Event a -> String

382showEventType :: Event a -> String

377showEventType = \case

383showEventType = \case

378− EventRoot _ -> "EventRoot"

384+ EventRoot _ _ -> "EventRoot"

379 EventNever -> "EventNever"

385 EventNever -> "EventNever"

380 EventPush _ -> "EventPush"

386 EventPush _ -> "EventPush"

381 EventMerge _ -> "EventMerge"

387 EventMerge _ -> "EventMerge"

@@ -402,7 +408,7 @@ data EventSubscribed a

402-- the weak pointer to it in some cases.

408-- the weak pointer to it in some cases.

403

409

404{-# NOINLINE newRootSubscribed #-}

410{-# NOINLINE newRootSubscribed #-}

405−newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)

411+newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)

406newRootSubscribed occ subs =

412newRootSubscribed occ subs =

407 return $! RootSubscribed

413 return $! RootSubscribed

408 { rootSubscribedOccurrence = occ

414 { rootSubscribedOccurrence = occ

@@ -495,14 +501,14 @@ coincidence a = EventCoincidence $ Coincidence

495 , coincidenceSubscribed = unsafeNewIORef a Nothing

501 , coincidenceSubscribed = unsafeNewIORef a Nothing

496 }

502 }

497

503

498−newRoot :: IO (Root a)

504+newRoot :: IO (Root k)

499newRoot = do

505newRoot = do

500− occRef <- newIORef Nothing

506+ occRef <- newIORef DMap.empty

501− subscribedRef <- newIORef Nothing

507+ subscribedRef <- newIORef DMap.empty

502 return $ Root

508 return $ Root

503 { rootOccurrence = occRef

509 { rootOccurrence = occRef

504 , rootSubscribed = subscribedRef

510 , rootSubscribed = subscribedRef

505− , rootInit = const $ return $ return ()

511+ , rootInit = \_ _ -> return $ return ()

506 }

512 }

507

513

508propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()

514propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()

@@ -517,10 +523,16 @@ run :: [DSum RootTrigger] -> ResultM b -> IO b

517run roots after = do

523run roots after = do

518 when debugPropagate $ putStrLn "Running an event frame"

524 when debugPropagate $ putStrLn "Running an event frame"

519 result <- runFrame $ do

525 result <- runFrame $ do

520− forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do

526+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

527+ occBefore <- liftIO $ do

528+ occBefore <- readIORef occRef

521− liftIO $ writeIORef occRef $ Just a

529+ writeIORef occRef $ DMap.insert k a occBefore

522− scheduleClear occRef

530+ return occBefore

531+ if DMap.null occBefore

532+ then do scheduleRootClear occRef

533+ return $ Just r

534+ else return Nothing

523− forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do

535+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, k) :=> a) -> do

524 propagateAndUpdateSubscribersRef subscribersRef a

536 propagateAndUpdateSubscribersRef subscribersRef a

525 delayedRef <- EventM $ asks eventEnvDelayedMerges

537 delayedRef <- EventM $ asks eventEnvDelayedMerges

526 let go = do

538 let go = do

@@ -553,6 +565,8 @@ run roots after = do

553

565

554data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

566data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

555

567

568+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))

569+

556data SomeAssignment = forall a. SomeAssignment (Hold a) a

570data SomeAssignment = forall a. SomeAssignment (Hold a) a

557

571

558data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)

572data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)

@@ -717,7 +731,7 @@ readBehaviorTracked b = case b of

717

731

718readEvent :: Event a -> ResultM (Maybe a)

732readEvent :: Event a -> ResultM (Maybe a)

719readEvent e = case e of

733readEvent e = case e of

720− EventRoot r -> liftIO $ readIORef $ rootOccurrence r

734+ EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r

721 EventNever -> return Nothing

735 EventNever -> return Nothing

722 EventPush p -> do

736 EventPush p -> do

723 subscribed <- getPushSubscribed p

737 subscribed <- getPushSubscribed p

@@ -756,7 +770,7 @@ zeroRef = unsafePerformIO $ newIORef 0

756

770

757getEventSubscribed :: Event a -> EventM (EventSubscribed a)

771getEventSubscribed :: Event a -> EventM (EventSubscribed a)

758getEventSubscribed e = case e of

772getEventSubscribed e = case e of

759− EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r

773+ EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r

760 EventNever -> return EventSubscribedNever

774 EventNever -> return EventSubscribedNever

761 EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p

775 EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p

762 EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f

776 EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f

@@ -793,7 +807,7 @@ subscribeEventSubscribed es ws = case es of

793

807

794getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)

808getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)

795getEventSubscribedOcc es = case es of

809getEventSubscribedOcc es = case es of

796− EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r

810+ EventSubscribedRoot r -> rootSubscribedOccurrence r

797 EventSubscribedNever -> return Nothing

811 EventSubscribedNever -> return Nothing

798 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

812 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

799 EventSubscribedFan k subscribed -> do

813 EventSubscribedFan k subscribed -> do

@@ -824,21 +838,21 @@ noinlineFalse :: Bool

824noinlineFalse = False

838noinlineFalse = False

825{-# NOINLINE noinlineFalse #-}

839{-# NOINLINE noinlineFalse #-}

826

840

827−getRootSubscribed :: Root a -> EventM (RootSubscribed a)

841+getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)

828−getRootSubscribed r = do

842+getRootSubscribed k r = do

829 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

843 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

830− case mSubscribed of

844+ case DMap.lookup (WrapArg k) mSubscribed of

831 Just subscribed -> return subscribed

845 Just subscribed -> return subscribed

832 Nothing -> liftIO $ do

846 Nothing -> liftIO $ do

833 subscribersRef <- newIORef []

847 subscribersRef <- newIORef []

834− subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef

848+ subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef

835 -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory

849 -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory

836− uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)

850+ uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)

837 addFinalizer subscribed $ do

851 addFinalizer subscribed $ do

838 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

852 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

839-- putStrLn "Uninit root"

853-- putStrLn "Uninit root"

840 uninit

854 uninit

841− liftIO $ writeIORef (rootSubscribed r) $ Just subscribed

855+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed

842 return subscribed

856 return subscribed

843

857

844-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

858-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

@@ -1057,9 +1071,10 @@ runFrame a = do

1057 holdInitRef <- newIORef []

1071 holdInitRef <- newIORef []

1058 heightRef <- newIORef 0

1072 heightRef <- newIORef 0

1059 toClearRef <- newIORef []

1073 toClearRef <- newIORef []

1074+ toClearRootRef <- newIORef []

1060 coincidenceInfosRef <- newIORef []

1075 coincidenceInfosRef <- newIORef []

1061 delayedRef <- liftIO $ newIORef IntMap.empty

1076 delayedRef <- liftIO $ newIORef IntMap.empty

1062− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef heightRef coincidenceInfosRef delayedRef) $ do

1077+ result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do

1063 result <- a

1078 result <- a

1064 let runHoldInits = do

1079 let runHoldInits = do

1065 holdInits <- liftIO $ readIORef holdInitRef

1080 holdInits <- liftIO $ readIORef holdInitRef

@@ -1071,6 +1086,8 @@ runFrame a = do

1071 return result

1086 return result

1072 toClear <- readIORef toClearRef

1087 toClear <- readIORef toClearRef

1073 forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing

1088 forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing

1089+ toClearRoot <- readIORef toClearRootRef

1090+ forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty

1074 toAssign <- readIORef toAssignRef

1091 toAssign <- readIORef toAssignRef

1075 toReconnectRef <- newIORef []

1092 toReconnectRef <- newIORef []

1076 forM_ toAssign $ \(SomeAssignment h v) -> do

1093 forM_ toAssign $ \(SomeAssignment h v) -> do

@@ -1323,7 +1340,7 @@ instance R.MonadHold Spider EventM where

1323 {-# INLINE hold #-}

1340 {-# INLINE hold #-}

1324 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1341 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1325

1342

1326−newtype RootTrigger a = RootTrigger (IORef [WeakSubscriber a], IORef (Maybe a))

1343+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)

1327newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }

1344newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }

1328

1345

1329instance R.ReflexHost Spider where

1346instance R.ReflexHost Spider where

@@ -1359,22 +1376,33 @@ instance R.MonadHold Spider SpiderHostFrame where

1359 {-# INLINE hold #-}

1376 {-# INLINE hold #-}

1360 hold v0 e = SpiderHostFrame $ R.hold v0 e

1377 hold v0 e = SpiderHostFrame $ R.hold v0 e

1361

1378

1362−newEventWithTriggerIO :: (RootTrigger a -> IO (IO ())) -> IO (R.Event Spider a)

1379+newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)

1363newEventWithTriggerIO f = do

1380newEventWithTriggerIO f = do

1381+ es <- newFanEventWithTriggerIO $ \Refl -> f

1382+ return $ select es Refl

1383+

1384+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)

1385+newFanEventWithTriggerIO f = do

1364− occRef <- newIORef Nothing

1386+ occRef <- newIORef DMap.empty

1365− subscribedRef <- newIORef Nothing

1387+ subscribedRef <- newIORef DMap.empty

1366 let !r = Root

1388 let !r = Root

1367 { rootOccurrence = occRef

1389 { rootOccurrence = occRef

1368 , rootSubscribed = subscribedRef

1390 , rootSubscribed = subscribedRef

1369 , rootInit = f

1391 , rootInit = f

1370 }

1392 }

1371− return $ SpiderEvent $ EventRoot r

1393+ return $ EventSelector $ \k -> EventRoot k r

1372

1394

1373instance R.MonadReflexCreateTrigger Spider SpiderHost where

1395instance R.MonadReflexCreateTrigger Spider SpiderHost where

1374− newEventWithTrigger = SpiderHost . newEventWithTriggerIO

1396+ newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO

1397+ newFanEventWithTrigger f = SpiderHost $ do

1398+ es <- newFanEventWithTriggerIO f

1399+ return $ R.EventSelector $ SpiderEvent . select es

1375

1400

1376instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where

1401instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where

1377− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . newEventWithTriggerIO

1402+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO

1403+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

1404+ es <- newFanEventWithTriggerIO f

1405+ return $ R.EventSelector $ SpiderEvent . select es

1378

1406

1379instance R.MonadReflexHost Spider SpiderHost where

1407instance R.MonadReflexHost Spider SpiderHost where

1380 fireEventsAndRead es a = SpiderHost $ run es a

1408 fireEventsAndRead es a = SpiderHost $ run es a