61f6f0f · patch · git.iko.soy

76-- Note: must come last to silence warnings due to AMP on GHC < 7.10

77import Prelude hiding (any, concat, mapM, mapM_, sequence)

78

79−type SubscriberList a = WeakBag (Subscriber a)

79+type SubscriberList x a = WeakBag (Subscriber x a)

80−type SubscriberListTicket a = WeakBagTicket (Subscriber a)

80+type SubscriberListTicket x a = WeakBagTicket (Subscriber x a)

81

82debugPropagate :: Bool

83

98class HasNodeId a where

99 getNodeId :: a -> Int

100

101−instance HasNodeId (Hold p a) where

101+instance HasNodeId (Hold x p a) where

102 getNodeId = holdNodeId

103

104−instance HasNodeId (PushSubscribed a b) where

104+instance HasNodeId (PushSubscribed x a b) where

105 getNodeId = pushSubscribedNodeId

106

107−instance HasNodeId (SwitchSubscribed a) where

107+instance HasNodeId (SwitchSubscribed x a) where

108 getNodeId = switchSubscribedNodeId

109

110−instance HasNodeId (MergeSubscribed a) where

110+instance HasNodeId (MergeSubscribed x a) where

111 getNodeId = mergeSubscribedNodeId

112

113−instance HasNodeId (FanSubscribed a) where

113+instance HasNodeId (FanSubscribed x a) where

114 getNodeId = fanSubscribedNodeId

115

116−instance HasNodeId (CoincidenceSubscribed a) where

116+instance HasNodeId (CoincidenceSubscribed x a) where

117 getNodeId = coincidenceSubscribedNodeId

118

119−instance HasNodeId (RootSubscribed a) where

119+instance HasNodeId (RootSubscribed x a) where

120 getNodeId = rootSubscribedNodeId

121

122−instance HasNodeId (Pull a) where

122+instance HasNodeId (Pull x a) where

123 getNodeId = pullNodeId

124

125{-# INLINE showNodeId #-}

126showNodeId :: HasNodeId a => a -> String

127showNodeId = ("#"<>) . show . getNodeId

128

129−showSubscriberType :: Subscriber a -> String

129+showSubscriberType :: Subscriber x a -> String

130showSubscriberType = \case

131 SubscriberPush _ _ -> "SubscriberPush"

132 SubscriberMerge _ _ -> "SubscriberMerge"

139 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

140 SubscriberHandle -> "SubscriberHandle"

141

142−showEventType :: Event a -> String

142+showEventType :: Event x a -> String

143showEventType = \case

144 EventRoot _ _ -> "EventRoot"

145 EventNever -> "EventNever"

187-- Event

188--------------------------------------------------------------------------------

189

190−newtype Event a = Event { subscribe :: forall x. Subscriber a -> EventM x (EventSubscription a) }

190+newtype Event x a = Event { subscribe :: Subscriber x a -> EventM x (EventSubscription x a) }

191

192−wrap :: Monad m => (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> Subscriber a -> m (EventSubscription a)

192+wrap :: Monad m => (t -> EventSubscribed x a) -> (Subscriber x a -> m (SubscriberListTicket x a, t)) -> Subscriber x a -> m (EventSubscription x a)

193wrap tag getSpecificSubscribed sub = do

194 (sln, subd) <- getSpecificSubscribed sub

195 return $ EventSubscription (Just sln) $ tag subd

196

197−eventRoot :: GCompare k => k a -> Root k -> Event a

197+eventRoot :: GCompare k => k a -> Root x k -> Event x a

198eventRoot !k !r = Event $ wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r

199

200−eventNever :: Event a

200+eventNever :: Event x a

201eventNever = Event $ \_ -> return $ EventSubscription Nothing EventSubscribedNever

202

203−eventPush :: Push b a -> Event a

203+eventPush :: Push x b a -> Event x a

204eventPush !p = Event $ wrap EventSubscribedPush $ getPushSubscribed p

205

206−eventMerge :: (GCompare k, a ~ DMap k Identity) => Merge k -> Event a

206+eventMerge :: (GCompare k, a ~ DMap k Identity) => Merge x k -> Event x a

207eventMerge !m = Event $ wrap EventSubscribedMerge $ getMergeSubscribed m

208

209−eventFan :: GCompare k => k a -> Fan k -> Event a

209+eventFan :: GCompare k => k a -> Fan x k -> Event x a

210eventFan !k !f = Event $ wrap (EventSubscribedFan k) $ getFanSubscribed k f

211

212−eventSwitch :: Switch a -> Event a

212+eventSwitch :: Switch x a -> Event x a

213eventSwitch !s = Event $ wrap EventSubscribedSwitch $ getSwitchSubscribed s

214

215−eventCoincidence :: Coincidence a -> Event a

215+eventCoincidence :: Coincidence x a -> Event x a

216eventCoincidence !c = Event $ wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c

217

218−eventHold :: (a ~ p b, R.Patch p) => Hold p b -> Event a

218+eventHold :: (a ~ p b, R.Patch p) => Hold x p b -> Event x a

219eventHold !h = Event $ subscribeHoldEvent h

220

221−eventDyn :: (a ~ p b, R.Patch p) => Dyn p b -> Event a

221+eventDyn :: (a ~ p b, R.Patch p) => Dyn x p b -> Event x a

222eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

223

224−eventHoldIdentity :: (a ~ Identity b) => Hold Identity b -> Event a

224+eventHoldIdentity :: (a ~ Identity b) => Hold x Identity b -> Event x a

225eventHoldIdentity !h = Event $ subscribeHoldEvent h

226

227−eventDynIdentity :: (a ~ Identity b) => Dyn Identity b -> Event a

227+eventDynIdentity :: (a ~ Identity b) => Dyn x Identity b -> Event x a

228eventDynIdentity !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

229

230{-# INLINE subscribeCoincidenceInner #-}

231−subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)

231+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x a)

232subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

233 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

234 subscription@(EventSubscription _ innerSubd) <- subscribe inner subInner

242-- EventSubscribed

243--------------------------------------------------------------------------------

244

245−data EventSubscribed a

245+data EventSubscribed x a

246− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)

246+ = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed x a)

247 | EventSubscribedNever

248− | forall b. EventSubscribedPush !(PushSubscribed b a)

248+ | forall b. EventSubscribedPush !(PushSubscribed x b a)

249− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)

249+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed x k)

250− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)

250+ | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed x k)

251− | EventSubscribedSwitch !(SwitchSubscribed a)

251+ | EventSubscribedSwitch !(SwitchSubscribed x a)

252− | EventSubscribedCoincidence !(CoincidenceSubscribed a)

252+ | EventSubscribedCoincidence !(CoincidenceSubscribed x a)

253

254−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)

254+readEventSubscribed :: EventSubscribed x a -> IO (Maybe a)

255readEventSubscribed = \case

256 EventSubscribedRoot rs -> readRootSubscribed rs

257 EventSubscribedNever -> return Nothing

262 EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs

263

264{-# INLINE subscribeEventSubscribed #-}

265−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))

265+subscribeEventSubscribed :: EventSubscribed x a -> Subscriber x a -> IO (Maybe (SubscriberListTicket x a))

266subscribeEventSubscribed es sub = case es of

267 EventSubscribedRoot r -> do

268 traceSubscribe $ "subscribeEventSubscribed Root"

287 Just <$> subscribeCoincidenceSubscribed subscribed sub

288

289{-# INLINE eventSubscribedGetParents #-}

290−eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]

290+eventSubscribedGetParents :: EventSubscribed x a -> IO [Some (EventSubscribed x)]

291eventSubscribedGetParents = \case

292 EventSubscribedRoot _ -> return []

293 EventSubscribedNever -> return []

305 innerParents = maybeToList $ fmap Some.This innerSubscription

306 return $ outerParent : innerParents

307

308−getEventSubscribedHeight :: EventSubscribed a -> IO Height

308+getEventSubscribedHeight :: EventSubscribed x a -> IO Height

309getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

310

311{-# INLINE eventSubscribedHeightRef #-}

312−eventSubscribedHeightRef :: EventSubscribed a -> IORef Height

312+eventSubscribedHeightRef :: EventSubscribed x a -> IORef Height

313eventSubscribedHeightRef = \case

314 EventSubscribedRoot _ -> zeroRef

315 EventSubscribedNever -> zeroRef

319 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed

320 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed

321

322−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]

322+whoCreatedEventSubscribed :: EventSubscribed x a -> IO [String]

323whoCreatedEventSubscribed = \case

324 EventSubscribedRoot _ -> return ["root"]

325 EventSubscribedNever -> return ["never"]

330 EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

331

332{-# INLINE eventSubscribedHasOwnHeightRef #-}

333−eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool

333+eventSubscribedHasOwnHeightRef :: EventSubscribed x a -> Bool

334eventSubscribedHasOwnHeightRef = \case

335 EventSubscribedRoot _ -> False

336 EventSubscribedNever -> False

340 EventSubscribedSwitch _ -> True

341 EventSubscribedCoincidence _ -> True

342

343−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]

343+walkInvalidHeightParents :: EventSubscribed x a -> IO [Some (EventSubscribed x)]

344walkInvalidHeightParents s0 = do

345 subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do

346 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

355-- EventSubscription

356--------------------------------------------------------------------------------

357

358−data EventSubscription a = EventSubscription

358+data EventSubscription x a = EventSubscription

359− { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))

359+ { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket x a))

360− , _eventSubscription_subscribed :: !(EventSubscribed a)

360+ , _eventSubscription_subscribed :: !(EventSubscribed x a)

361 }

362

363−unsubscribe :: EventSubscription a -> IO ()

363+unsubscribe :: EventSubscription x a -> IO ()

364unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln

365

366--------------------------------------------------------------------------------

371--representational so we can use coerce

372

373--type role Hold representational

374−data Hold p a

374+data Hold x p a

375 = Hold { holdValue :: !(IORef a)

376− , holdInvalidators :: !(IORef [Weak Invalidator])

376+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])

377− , holdParent :: !(IORef (Either (Event (p a)) (EventSubscription (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef

377+ , holdParent :: !(IORef (Either (Event x (p a)) (EventSubscription x (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef

378#ifdef DEBUG_NODEIDS

379 , holdNodeId :: Int

380#endif

382

383data EventEnv x

384 = EventEnv { eventEnvSpiderEnv :: !(SpiderEnv x)

385− , eventEnvAssignments :: !(IORef [SomeAssignment]) -- Needed for Subscribe

385+ , eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

386− , eventEnvHoldInits :: !(IORef [SomeHoldInit]) -- Needed for Subscribe

386+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

387− , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate])

387+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

388− , eventEnvMergeInits :: !(IORef [SomeMergeInit]) -- Needed for Subscribe

388+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

389 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

390 , eventEnvRootClears :: !(IORef [SomeRootClear])

391 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

392− , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence]) -- Needed for Subscribe

392+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

393− , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))

393+ , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge x]))

394 }

395

396{-# INLINE runEventM #-}

406 q <- getDeferralQueue

407 liftIO $ modifyIORef' q (a:)

408

409−instance Defer SomeAssignment (EventM x) where

409+instance Defer (SomeAssignment x) (EventM x) where

410 {-# INLINE getDeferralQueue #-}

411 getDeferralQueue = EventM $ asks eventEnvAssignments

412

413−instance Defer SomeHoldInit (EventM x) where

413+instance Defer (SomeHoldInit x) (EventM x) where

414 {-# INLINE getDeferralQueue #-}

415 getDeferralQueue = EventM $ asks eventEnvHoldInits

416

417−instance Defer SomeHoldInit BehaviorM where

417+instance Defer (SomeHoldInit x) (BehaviorM x) where

418 {-# INLINE getDeferralQueue #-}

419 getDeferralQueue = BehaviorM $ asks snd

420

421−instance Defer SomeMergeUpdate (EventM x) where

421+instance Defer (SomeMergeUpdate x) (EventM x) where

422 {-# INLINE getDeferralQueue #-}

423 getDeferralQueue = EventM $ asks eventEnvMergeUpdates

424

425−instance Defer SomeMergeInit (EventM x) where

425+instance Defer (SomeMergeInit x) (EventM x) where

426 {-# INLINE getDeferralQueue #-}

427 getDeferralQueue = EventM $ asks eventEnvMergeInits

428

429−class HasCurrentHeight m where

429+class HasCurrentHeight x m | m -> x where

430 getCurrentHeight :: m Height

431− scheduleMerge :: Height -> MergeSubscribed a -> m ()

431+ scheduleMerge :: Height -> MergeSubscribed x a -> m ()

432

433−instance HasCurrentHeight (EventM x) where

433+instance HasCurrentHeight x (EventM x) where

434 {-# INLINE getCurrentHeight #-}

435 getCurrentHeight = EventM $ do

436 heightRef <- asks eventEnvCurrentHeight

473scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()

474scheduleRootClear r = defer $ SomeRootClear r

475

476−instance Defer SomeResetCoincidence (EventM x) where

476+instance Defer (SomeResetCoincidence x) (EventM x) where

477 {-# INLINE getDeferralQueue #-}

478 getDeferralQueue = EventM $ asks eventEnvResetCoincidences

479

480-- Note: hold cannot examine its event until after the phase is over

481−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> EventM x (Hold p a) #-}

481+{-# SPECIALIZE hold :: R.Patch p => a -> Event x (p a) -> EventM x (Hold x p a) #-}

482−{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> ComputeM (Hold p a) #-}

482+{-# SPECIALIZE hold :: R.Patch p => a -> Event x (p a) -> ComputeM x (Hold x p a) #-}

483−hold :: (R.Patch p, Defer SomeHoldInit m) => a -> Event (p a) -> m (Hold p a)

483+hold :: (R.Patch p, Defer (SomeHoldInit x) m) => a -> Event x (p a) -> m (Hold x p a)

484hold v0 e = do

485 valRef <- liftIO $ newIORef v0

486 invsRef <- liftIO $ newIORef []

500 return h

501

502{-# INLINE getHoldEventSubscription #-}

503−getHoldEventSubscription :: forall m p a x. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeClear m, R.Patch p, HasCurrentHeight m, Defer SomeMergeInit m, Defer SomeResetCoincidence m, HasSpiderEnv x m, m ~ EventM x) => Hold p a -> m (EventSubscription (p a))

503+getHoldEventSubscription :: forall m p a x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x) => Hold x p a -> m (EventSubscription x (p a))

504getHoldEventSubscription h = do

505 ep <- liftIO $ readIORef $ holdParent h

506 case ep of

524 liftIO $ writeIORef (holdParent h) $ Right subscription

525 return subscription

526

527−type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])

527+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

528

529--type role BehaviorM representational

530-- BehaviorM can sample behaviors

531−newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT BehaviorEnv IO a } deriving (Functor, Applicative, MonadIO, MonadFix)

531+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)

532

533−instance Monad BehaviorM where

533+instance Monad (BehaviorM x) where

534 {-# INLINE (>>=) #-}

535 BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f

536 {-# INLINE (>>) #-}

540 {-# INLINE fail #-}

541 fail s = BehaviorM $ fail s

542

543−data BehaviorSubscribed a

543+data BehaviorSubscribed x a

544− = forall p. BehaviorSubscribedHold (Hold p a)

544+ = forall p. BehaviorSubscribedHold (Hold x p a)

545− | BehaviorSubscribedPull (PullSubscribed a)

545+ | BehaviorSubscribedPull (PullSubscribed x a)

546

547−data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)

547+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)

548

549--type role PullSubscribed representational

550−data PullSubscribed a

550+data PullSubscribed x a

551 = PullSubscribed { pullSubscribedValue :: !a

552− , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])

552+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])

553− , pullSubscribedOwnInvalidator :: !Invalidator

553+ , pullSubscribedOwnInvalidator :: !(Invalidator x)

554− , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated

554+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated

555 }

556

557--type role Pull representational

558−data Pull a

558+data Pull x a

559− = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))

559+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))

560− , pullCompute :: !(BehaviorM a)

560+ , pullCompute :: !(BehaviorM x a)

561#ifdef DEBUG_NODEIDS

562 , pullNodeId :: Int

563#endif

564 }

565

566−data Invalidator

566+data Invalidator x

567− = forall a. InvalidatorPull (Pull a)

567+ = forall a. InvalidatorPull (Pull x a)

568− | forall a. InvalidatorSwitch (SwitchSubscribed a)

568+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)

569

570−data RootSubscribed a = forall k. GCompare k => RootSubscribed

570+data RootSubscribed x a = forall k. GCompare k => RootSubscribed

571 { rootSubscribedKey :: !(k a)

572− , rootSubscribedCachedSubscribed :: !(IORef (DMap k RootSubscribed)) -- From the original Root

572+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root

573− , rootSubscribedSubscribers :: !(SubscriberList a)

573+ , rootSubscribedSubscribers :: !(SubscriberList x a)

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

575 , rootSubscribedUninit :: IO ()

576− , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?

576+ , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed x a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?

577#ifdef DEBUG_NODEIDS

578 , rootSubscribedNodeId :: Int

579#endif

580 }

581

582−data Root (k :: * -> *)

582+data Root x (k :: * -> *)

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

584− , rootSubscribed :: !(IORef (DMap k RootSubscribed))

584+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

585− , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))

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

586 }

587

588−data SomeHoldInit = forall p a. R.Patch p => SomeHoldInit !(Hold p a)

588+data SomeHoldInit x = forall p a. R.Patch p => SomeHoldInit !(Hold x p a)

589

590−data SomeMergeUpdate = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k Event)) (MergeSubscribed k)

590+data SomeMergeUpdate x = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k (Event x))) (MergeSubscribed x k)

591

592−data SomeMergeInit = forall k. GCompare k => SomeMergeInit !(MergeSubscribed k) !(Event (R.PatchDMap (DMap k Event)))

592+data SomeMergeInit x = forall k. GCompare k => SomeMergeInit !(MergeSubscribed x k) !(Event x (R.PatchDMap (DMap k (Event x))))

593

594−data SomeEventSubscription = forall a. SomeEventSubscription (EventSubscription a)

594+data SomeEventSubscription x = forall a. SomeEventSubscription (EventSubscription x a)

595

596-- EventM can do everything BehaviorM can, plus create holds

597−newtype EventM x a = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

597+newtype EventM x (a :: *) = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

598

599−data PushSubscribed a b

599+data PushSubscribed x a b

600− = PushSubscribed { pushSubscribedCachedSubscribed :: !(IORef (Maybe (PushSubscribed a b)))

600+ = PushSubscribed { pushSubscribedCachedSubscribed :: !(IORef (Maybe (PushSubscribed x a b)))

601 , pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)

602 , pushSubscribedHeight :: !(IORef Height)

603− , pushSubscribedSubscribers :: !(SubscriberList b)

603+ , pushSubscribedSubscribers :: !(SubscriberList x b)

604− , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die --TODO: Probably unneeded now

604+ , pushSubscribedSelf :: !(Subscriber x a) -- Hold this in memory to ensure our WeakReferences don't die --TODO: Probably unneeded now

605− , pushSubscribedWeakSelf :: !(IORef (Weak (PushSubscribed a b)))

605+ , pushSubscribedWeakSelf :: !(IORef (Weak (PushSubscribed x a b)))

606− , pushSubscribedParent :: !(EventSubscription a)

606+ , pushSubscribedParent :: !(EventSubscription x a)

607#ifdef DEBUG_NODEIDS

608 , pushSubscribedNodeId :: Int

609#endif

610 }

611

612−newtype ComputeM a = ComputeM (ReaderT (IORef [SomeHoldInit]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

612+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

613

614−instance Defer SomeHoldInit ComputeM where

614+instance Defer (SomeHoldInit x) (ComputeM x) where

615 getDeferralQueue = ComputeM ask

616

617−{-# SPECIALIZE runComputeM :: ComputeM a -> EventM x a #-}

617+{-# SPECIALIZE runComputeM :: ComputeM x a -> EventM x a #-}

618−runComputeM :: Defer SomeHoldInit m => ComputeM a -> m a

618+runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

619runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

620

621−data Push a b

621+data Push x a b

622− = Push { pushCompute :: !(a -> ComputeM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed --TODO: This only uses Defer SomeHoldInit EventM; perhaps only the hold init queue should be passed in (also, perhaps those hold inits can be accelerated - can there be a loop we would need to worry about?)

622+ = Push { pushCompute :: !(a -> ComputeM x (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed --TODO: This only uses Defer SomeHoldInit EventM; perhaps only the hold init queue should be passed in (also, perhaps those hold inits can be accelerated - can there be a loop we would need to worry about?)

623− , pushParent :: !(Event a)

623+ , pushParent :: !(Event x a)

624− , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?

624+ , pushSubscribed :: !(IORef (Maybe (PushSubscribed x a b))) --TODO: Can we replace this with an unsafePerformIO thunk?

625 }

626

627−data MergeSubscribedParent k a = MergeSubscribedParent !(EventSubscription a) !(Subscriber a)

627+data MergeSubscribedParent (x :: *) k a = MergeSubscribedParent !(EventSubscription x a) !(Subscriber x a)

628

629−mergeSubscribedParentSubscription :: MergeSubscribedParent k a -> EventSubscription a

629+mergeSubscribedParentSubscription :: MergeSubscribedParent x k a -> EventSubscription x a

630mergeSubscribedParentSubscription (MergeSubscribedParent es _) = es

631

632data HeightBag = HeightBag

671heightBagVerify = id

672#endif

673

674−data MergeSubscribed k

674+data MergeSubscribed x k

675− = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge

675+ = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed x k))) -- From the original merge

676 , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

677 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

678 , mergeSubscribedHeight :: !(IORef Height)

679 , mergeSubscribedHeightBag :: !(IORef HeightBag)

680− , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))

680+ , mergeSubscribedSubscribers :: !(SubscriberList x (DMap k Identity))

681− , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))

681+ , mergeSubscribedChange :: !(IORef (Subscriber x (R.PatchDMap (DMap k (Event x))), EventSubscribed x (R.PatchDMap (DMap k (Event x)))))

682− , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))

682+ , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent x k)))

683− , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed k)))

683+ , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed x k)))

684#ifdef DEBUG_NODEIDS

685 , mergeSubscribedNodeId :: Int

686#endif

687 }

688

689--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)

690−data Merge k

690+data Merge x k

691− = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))

691+ = Merge { mergeParents :: !(Dynamic x R.PatchDMap (DMap k (Event x)))

692− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))

692+ , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed x k)))

693 }

694

695−data FanSubscribedChildren k a = FanSubscribedChildren

695+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

696− { _fanSubscribedChildren_list :: !(SubscriberList a)

696+ { _fanSubscribedChildren_list :: !(SubscriberList x a)

697− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed k)

697+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)

698− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))

698+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))

699 }

700

701−data FanSubscribed k

701+data FanSubscribed (x :: *) k

702− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))

702+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

703− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty

703+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty

704− , fanSubscribedParent :: !(EventSubscription (DMap k Identity))

704+ , fanSubscribedParent :: !(EventSubscription x (DMap k Identity))

705#ifdef DEBUG_NODEIDS

706 , fanSubscribedNodeId :: Int

707#endif

708 }

709

710−data Fan k

710+data Fan x k

711− = Fan { fanParent :: !(Event (DMap k Identity))

711+ = Fan { fanParent :: !(Event x (DMap k Identity))

712− , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))

712+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

713 }

714

715−data SwitchSubscribed a

715+data SwitchSubscribed x a

716− = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))

716+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))

717 , switchSubscribedOccurrence :: !(IORef (Maybe a))

718 , switchSubscribedHeight :: !(IORef Height)

719− , switchSubscribedSubscribers :: !(SubscriberList a)

719+ , switchSubscribedSubscribers :: !(SubscriberList x a)

720− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator

720+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)

721− , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))

721+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))

722− , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])

722+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])

723− , switchSubscribedParent :: !(Behavior (Event a))

723+ , switchSubscribedParent :: !(Behavior x (Event x a))

724− , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))

724+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x a))

725− , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))

725+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))

726#ifdef DEBUG_NODEIDS

727 , switchSubscribedNodeId :: Int

728#endif

729 }

730

731−data Switch a

731+data Switch x a

732− = Switch { switchParent :: !(Behavior (Event a))

732+ = Switch { switchParent :: !(Behavior x (Event x a))

733− , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))

733+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))

734 }

735

736{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}

737−data CoincidenceSubscribed a

737+data CoincidenceSubscribed x a

738− = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))

738+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))

739 , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))

740− , coincidenceSubscribedSubscribers :: !(SubscriberList a)

740+ , coincidenceSubscribedSubscribers :: !(SubscriberList x a)

741 , coincidenceSubscribedHeight :: !(IORef Height)

742− , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))

742+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))

743− , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))

743+ , coincidenceSubscribedOuterParent :: !(EventSubscription x (Event x a))

744− , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))

744+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x a)))

745− , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))

745+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))

746#ifdef DEBUG_NODEIDS

747 , coincidenceSubscribedNodeId :: Int

748#endif

749 }

750

751−data Coincidence a

751+data Coincidence x a

752− = Coincidence { coincidenceParent :: !(Event (Event a))

752+ = Coincidence { coincidenceParent :: !(Event x (Event x a))

753− , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))

753+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))

754 }

755

756−data Subscriber a

756+data Subscriber x a

757− = forall b. SubscriberPush (a -> ComputeM (Maybe b)) (PushSubscribed a b) --TODO: Why does this have the pushCompute in it?

757+ = forall b. SubscriberPush (a -> ComputeM x (Maybe b)) (PushSubscribed x a b) --TODO: Why does this have the pushCompute in it?

758− | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?

758+ | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed x k) --TODO: Can we inline the GCompare?

759− | forall k. (a ~ R.PatchDMap (DMap k Event), GCompare k) => SubscriberMergeChange (MergeSubscribed k)

759+ | forall k. (a ~ R.PatchDMap (DMap k (Event x)), GCompare k) => SubscriberMergeChange (MergeSubscribed x k)

760− | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)

760+ | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed x k)

761− | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold p b)

761+ | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold x p b)

762− | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold Identity b)

762+ | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold x Identity b)

763− | SubscriberSwitch (SwitchSubscribed a)

763+ | SubscriberSwitch (SwitchSubscribed x a)

764− | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)

764+ | forall b. a ~ Event x b => SubscriberCoincidenceOuter (CoincidenceSubscribed x b)

765− | SubscriberCoincidenceInner (CoincidenceSubscribed a)

765+ | SubscriberCoincidenceInner (CoincidenceSubscribed x a)

766 | SubscriberHandle

767

768-- These function are constructor functions that are marked NOINLINE so they are

776

777--TODO: I think all of these noinlines are now unnecessary

778{-# NOINLINE newSubscriberPush #-}

779−newSubscriberPush :: (a -> ComputeM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)

779+newSubscriberPush :: (a -> ComputeM x (Maybe b)) -> PushSubscribed x a b -> IO (Subscriber x a)

780newSubscriberPush compute subd = return $! SubscriberPush compute subd

781

782{-# RULES

783 "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h

784 #-}

785{-# NOINLINE newSubscriberHold #-}

786−newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))

786+newSubscriberHold :: R.Patch p => Hold x p a -> IO (Subscriber x (p a))

787newSubscriberHold h = return $! SubscriberHold h

788

789{-# NOINLINE newSubscriberHoldIdentity #-}

790−newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))

790+newSubscriberHoldIdentity :: Hold x Identity a -> IO (Subscriber x (Identity a))

791newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h

792

793{-# NOINLINE newSubscriberMerge #-}

794−newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)

794+newSubscriberMerge :: GCompare k => k a -> MergeSubscribed x k -> IO (Subscriber x a)

795newSubscriberMerge k subd = return $! SubscriberMerge k subd

796

797{-# NOINLINE newSubscriberMergeChange #-}

798−newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))

798+newSubscriberMergeChange :: GCompare k => MergeSubscribed x k -> IO (Subscriber x (R.PatchDMap (DMap k (Event x))))

799newSubscriberMergeChange subd = return $! SubscriberMergeChange subd

800

801{-# NOINLINE newSubscriberFan #-}

802−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))

802+newSubscriberFan :: GCompare k => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))

803newSubscriberFan subd = return $! SubscriberFan subd

804

805{-# NOINLINE newSubscriberSwitch #-}

806−newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)

806+newSubscriberSwitch :: SwitchSubscribed x a -> IO (Subscriber x a)

807newSubscriberSwitch subd = return $! SubscriberSwitch subd

808

809{-# NOINLINE newSubscriberCoincidenceOuter #-}

810−newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))

810+newSubscriberCoincidenceOuter :: CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

811newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd

812

813{-# NOINLINE newSubscriberCoincidenceInner #-}

814−newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)

814+newSubscriberCoincidenceInner :: CoincidenceSubscribed x a -> IO (Subscriber x a)

815newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd

816

817{-# NOINLINE newInvalidatorSwitch #-}

818−newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator

818+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)

819newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

820

821{-# NOINLINE newInvalidatorPull #-}

822−newInvalidatorPull :: Pull a -> IO Invalidator

822+newInvalidatorPull :: Pull x a -> IO (Invalidator x)

823newInvalidatorPull p = return $! InvalidatorPull p

824

825−data Dynamic p a

825+data Dynamic x p a

826− = DynamicHold !(Hold p a)

826+ = DynamicHold !(Hold x p a)

827− | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)

827+ | p ~ Identity => DynamicHoldIdentity !(Hold x Identity a)

828 | DynamicConst !a

829− | DynamicDyn !(Dyn p a)

829+ | DynamicDyn !(Dyn x p a)

830− | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)

830+ | p ~ Identity => DynamicDynIdentity !(Dyn x Identity a)

831

832{-# INLINE current #-}

833−current :: R.Patch p => Dynamic p a -> Behavior a

833+current :: R.Patch p => Dynamic x p a -> Behavior x a

834current = \case

835 DynamicHold h -> BehaviorHold h

836 DynamicHoldIdentity h -> BehaviorHoldIdentity h

840

841--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?

842{-# INLINE updated #-}

843−updated :: R.Patch p => Dynamic p a -> Event (p a)

843+updated :: R.Patch p => Dynamic x p a -> Event x (p a)

844updated = \case

845 DynamicHold h -> eventHold h

846 DynamicHoldIdentity h -> eventHoldIdentity h

848 DynamicDyn d -> eventDyn d

849 DynamicDynIdentity d -> eventDynIdentity d

850

851−newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b

851+newMapDyn :: (a -> b) -> Dynamic x Identity a -> Dynamic x Identity b

852newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (Identity . f . runIdentity <$> updated d)

853

854−instance Functor (Dynamic Identity) where

854+instance Functor (Dynamic x Identity) where

855 fmap = newMapDyn

856

857−instance Applicative (Dynamic Identity) where

857+instance Applicative (Dynamic x Identity) where

858 pure = DynamicConst

859 (<*>) = zipDynWith ($)

860 _ *> b = b

861 a <* _ = a

862

863−instance R.FunctorMaybe Event where

863+instance R.FunctorMaybe (Event x) where

864 fmapMaybe f = push $ return . f

865

866−instance Align Event where

866+instance Align (Event x) where

867 nil = eventNever

868 align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]

869

870--TODO: Avoid the duplication between this and R.zipDynWith

871−zipDynWith :: (a -> b -> c) -> Dynamic Identity a -> Dynamic Identity b -> Dynamic Identity c

871+zipDynWith :: (a -> b -> c) -> Dynamic x Identity a -> Dynamic x Identity b -> Dynamic x Identity c

872zipDynWith f da db =

873 let eab = align (updated da) (updated db)

874 ec = flip push eab $ \o -> do

883 return $ Just $ Identity $ f a b

884 in DynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (current da) <*> readBehaviorUntracked (current db)) ec

885

886−instance Monad (Dynamic Identity) where

886+instance Monad (Dynamic x Identity) where

887 {-# INLINE return #-}

888 return = pure

889 {-# INLINE (>>=) #-}

893 {-# INLINE fail #-}

894 fail _ = error "Dynamic does not support 'fail'"

895

896−newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }

896+newtype Dyn x p a = Dyn { unDyn :: IORef (Either (BehaviorM x a, Event x (p a)) (Hold x p a)) }

897

898−unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a

898+unsafeDyn :: BehaviorM x a -> Event x (p a) -> Dyn x p a

899unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

900 where x = (readV0, v')

901

902−newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a

902+newJoinDyn :: Dynamic x Identity (Dynamic x Identity a) -> Dyn x Identity a

903newJoinDyn d =

904 let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)

905 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d

909 in unsafeDyn readV0 v'

910

911--type role Behavior representational

912−data Behavior a

912+data Behavior x a

913− = forall p. BehaviorHold !(Hold p a)

913+ = forall p. BehaviorHold !(Hold x p a)

914− | BehaviorHoldIdentity !(Hold Identity a)

914+ | BehaviorHoldIdentity !(Hold x Identity a)

915 | BehaviorConst !a

916− | BehaviorPull !(Pull a)

916+ | BehaviorPull !(Pull x a)

917− | BehaviorDynIdentity !(Dyn Identity a)

917+ | BehaviorDynIdentity !(Dyn x Identity a)

918− | forall p. R.Patch p => BehaviorDyn !(Dyn p a)

918+ | forall p. R.Patch p => BehaviorDyn !(Dyn x p a)

919

920-- ResultM can read behaviors and events

921type ResultM = EventM

924unsafeNewIORef :: a -> b -> IORef b

925unsafeNewIORef _ b = unsafePerformIO $ newIORef b

926

927−instance Functor Event where

927+instance Functor (Event x) where

928 fmap f = push $ return . Just . f

929

930−instance Functor Behavior where

930+instance Functor (Behavior x) where

931 fmap f = pull . fmap f . readBehaviorTracked

932

933{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly

934−push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b

934+push :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

935push f e = eventPush $ Push

936 { pushCompute = f

937 , pushParent = e

940-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}

941

942{-# NOINLINE pull #-}

943−pull :: BehaviorM a -> Behavior a

943+pull :: BehaviorM x a -> Behavior x a

944pull a = BehaviorPull $ Pull

945 { pullCompute = a

946 , pullValue = unsafeNewIORef a Nothing

950 }

951

952{-# NOINLINE switch #-}

953−switch :: Behavior (Event a) -> Event a

953+switch :: Behavior x (Event x a) -> Event x a

954switch a = eventSwitch $ Switch

955 { switchParent = a

956 , switchSubscribed = unsafeNewIORef a Nothing

957 }

958

959−coincidence :: Event (Event a) -> Event a

959+coincidence :: Event x (Event x a) -> Event x a

960coincidence a = eventCoincidence $ Coincidence

961 { coincidenceParent = a

962 , coincidenceSubscribed = unsafeNewIORef a Nothing

963 }

964

965−propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()

965+propagateAndUpdateSubscribersRef :: SubscriberList x a -> a -> EventM x ()

966propagateAndUpdateSubscribersRef subscribersRef a = do

967 propagate a subscribersRef

968

969-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

970−run :: [DSum RootTrigger Identity] -> ResultM x b -> SpiderHost x b

970+run :: [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

971run roots after = do

972 tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"

973 spiderEnv <- SpiderHost ask

1016

1017data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))

1018

1019−data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a

1019+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1020

1021−data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)

1021+data DelayedMerge x = forall k. DelayedMerge (MergeSubscribed x k)

1022

1023debugFinalize :: Bool

1024debugFinalize = False

1093listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1094

1095-- | Propagate everything at the current height

1096−propagate :: a -> SubscriberList a -> EventM x ()

1096+propagate :: a -> SubscriberList x a -> EventM x ()

1097propagate a subscribers = withIncreasedDepth $ do

1098 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

1099 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

1178 SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"

1179

1180{-# INLINE propagateSubscriberHold #-}

1181−propagateSubscriberHold :: R.Patch p => Hold p a -> p a -> EventM x ()

1181+propagateSubscriberHold :: R.Patch p => Hold x p a -> p a -> EventM x ()

1182propagateSubscriberHold h a = do

1183 {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do

1184 invalidators <- liftIO $ readIORef $ holdInvalidators h

1192 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1193 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

1194

1195−data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1195+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x a) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1196

1197−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}

1197+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}

1198−{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}

1198+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}

1199−readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a

1199+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

1200readBehaviorUntracked b = do

1201 holdInits <- getDeferralQueue

1202 liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases

1203

1204−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IORef [SomeHoldInit] -> IO a

1204+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1205runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1206

1207−askInvalidator :: BehaviorM (Maybe (Weak Invalidator))

1207+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1208askInvalidator = do

1209 (!m, _) <- BehaviorM ask

1210 case m of

1211 Nothing -> return Nothing

1212 Just (!wi, _) -> return $ Just wi

1213

1214−askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))

1214+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1215askParentsRef = do

1216 (!m, _) <- BehaviorM ask

1217 case m of

1218 Nothing -> return Nothing

1219 Just (_, !p) -> return $ Just p

1220

1221−askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])

1221+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1222askBehaviorHoldInits = do

1223 (_, !his) <- BehaviorM ask

1224 return his

1225

1226−readBehaviorTracked :: Behavior a -> BehaviorM a

1226+readBehaviorTracked :: Behavior x a -> BehaviorM x a

1227readBehaviorTracked b = case b of

1228 BehaviorHold h -> readHoldTracked h

1229 BehaviorHoldIdentity h -> readHoldTracked h

1257 BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d

1258

1259{-# INLINE readHoldTracked #-}

1260−readHoldTracked :: Hold p a -> BehaviorM a

1260+readHoldTracked :: Hold x p a -> BehaviorM x a

1261readHoldTracked h = do

1262 result <- liftIO $ readIORef $ holdValue h

1263 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

1265 return result

1266

1267{-# INLINE getDynHold #-}

1268−getDynHold :: (Defer SomeHoldInit m, R.Patch p) => Dyn p a -> m (Hold p a)

1268+getDynHold :: (Defer (SomeHoldInit x) m, R.Patch p) => Dyn x p a -> m (Hold x p a)

1269getDynHold d = do

1270 mh <- liftIO $ readIORef $ unDyn d

1271 case mh of

1277 liftIO $ writeIORef (unDyn d) $ Right h

1278 return h

1279

1280−readRootSubscribed :: RootSubscribed a -> IO (Maybe a)

1280+readRootSubscribed :: RootSubscribed x a -> IO (Maybe a)

1281readRootSubscribed = rootSubscribedOccurrence

1282

1283−readPushSubscribed :: PushSubscribed b a -> IO (Maybe a)

1283+readPushSubscribed :: PushSubscribed x b a -> IO (Maybe a)

1284readPushSubscribed subscribed = do

1285 result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid

1286 touch $ pushSubscribedSelf subscribed

1287 return result

1288

1289−readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))

1289+readMergeSubscribed :: MergeSubscribed x k -> IO (Maybe (DMap k Identity))

1290readMergeSubscribed subscribed = do

1291 result <- readIORef $ mergeSubscribedOccurrence subscribed

1292 touch $ mergeSubscribedParents subscribed

1293 return result

1294

1295−readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)

1295+readFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> IO (Maybe a)

1296readFanSubscribed k fs = do

1297 parentOcc <- readEventSubscribed $ _eventSubscription_subscribed $ fanSubscribedParent fs

1298 return $ coerce $ DMap.lookup k =<< parentOcc

1299

1300−readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)

1300+readSwitchSubscribed :: SwitchSubscribed x a -> IO (Maybe a)

1301readSwitchSubscribed subscribed = do

1302 result <- readIORef $ switchSubscribedOccurrence subscribed

1303 touch $ switchSubscribedOwnInvalidator subscribed

1304 return result

1305

1306−readCoincidenceSubscribed :: CoincidenceSubscribed a -> IO (Maybe a)

1306+readCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO (Maybe a)

1307readCoincidenceSubscribed subscribed = do

1308 result <- readIORef $ coincidenceSubscribedOccurrence subscribed

1309 touch $ coincidenceSubscribedOuter subscribed

1316zeroRef = unsafePerformIO $ newIORef zeroHeight

1317

1318{-# INLINE subscribeHoldEvent #-}

1319−subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))

1319+subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold x p a -> Subscriber x (p a) -> m (EventSubscription x (p a))

1320subscribeHoldEvent h sub = do

1321 EventSubscription _ subd <- getHoldEventSubscription h

1322 sln <- liftIO $ subscribeEventSubscribed subd sub

1329

1330type CanSubscribe x m =

1331 ( HasSpiderEnv x m

1332− , HasCurrentHeight m

1332+ , HasCurrentHeight x m

1333− , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state

1333+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1334 , Defer SomeClear m -- Wiping out event firings

1335− , Defer SomeAssignment m -- Updating state

1335+ , Defer (SomeAssignment x) m -- Updating state

1336− , Defer SomeResetCoincidence m

1336+ , Defer (SomeResetCoincidence x) m

1337 , m ~ EventM x

1338 )

1339

1340−getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)

1340+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (SubscriberListTicket x a, RootSubscribed x a)

1341getRootSubscribed k r sub = do

1342 mSubscribed <- readIORef $ rootSubscribed r

1343 case DMap.lookup k mSubscribed of

1368 return (sln, subscribed)

1369

1370{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}

1371−cleanupRootSubscribed :: RootSubscribed a -> IO ()

1371+cleanupRootSubscribed :: RootSubscribed x a -> IO ()

1372cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do

1373 rootSubscribedUninit self

1374 modifyIORef' cached $ DMap.delete k

1375

1376{-# INLINE subscribeRootSubscribed #-}

1377−subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)

1377+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO (SubscriberListTicket x a)

1378subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1379

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

1381−{-# SPECIALIZE getPushSubscribed :: Push a b -> Subscriber b -> EventM x (SubscriberListTicket b, PushSubscribed a b) #-}

1381+{-# SPECIALIZE getPushSubscribed :: Push x a b -> Subscriber x b -> EventM x (SubscriberListTicket x b, PushSubscribed x a b) #-}

1382−getPushSubscribed :: CanSubscribe x m => Push a b -> Subscriber b -> m (SubscriberListTicket b, PushSubscribed a b)

1382+getPushSubscribed :: CanSubscribe x m => Push x a b -> Subscriber x b -> m (SubscriberListTicket x b, PushSubscribed x a b)

1383getPushSubscribed p sub = do

1384 mSubscribed <- liftIO $ readIORef $ pushSubscribed p

1385 case mSubscribed of

1415 liftIO $ writeIORef (pushSubscribed p) $ Just subscribed

1416 return (sln, subscribed)

1417

1418−cleanupPushSubscribed :: PushSubscribed a b -> IO ()

1418+cleanupPushSubscribed :: PushSubscribed x a b -> IO ()

1419cleanupPushSubscribed self = do

1420 unsubscribe $ pushSubscribedParent self

1421 writeIORef (pushSubscribedCachedSubscribed self) $ Nothing

1422

1423{-# INLINE subscribePushSubscribed #-}

1424−subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)

1424+subscribePushSubscribed :: PushSubscribed x a b -> Subscriber x b -> IO (SubscriberListTicket x b)

1425subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed

1426

1427−{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge k -> Subscriber (DMap k Identity) -> EventM x (SubscriberListTicket (DMap k Identity), MergeSubscribed k) #-}

1427+{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge x k -> Subscriber x (DMap k Identity) -> EventM x (SubscriberListTicket x (DMap k Identity), MergeSubscribed x k) #-}

1428−getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge k -> Subscriber (DMap k Identity) -> m (SubscriberListTicket (DMap k Identity), MergeSubscribed k)

1428+getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge x k -> Subscriber x (DMap k Identity) -> m (SubscriberListTicket x (DMap k Identity), MergeSubscribed x k)

1429getMergeSubscribed m sub = do

1430 mSubscribed <- liftIO $ readIORef $ mergeSubscribed m

1431 case mSubscribed of

1436 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"

1437 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1438 initialParents <- readBehaviorUntracked $ current $ mergeParents m

1439− subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> do

1439+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent x k))] <- forM (DMap.toList initialParents) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> do

1440 s <- {-# SCC "getMergeSubscribed.a.1" #-} liftIO $ newSubscriberMerge k subscribedUnsafe

1441 subscription@(EventSubscription _ parentSubd) <- {-# SCC "getMergeSubscribed.a.2" #-} subscribe e s

1442 parentOcc <- {-# SCC "getMergeSubscribed.a.3" #-} liftIO $ readEventSubscribed parentSubd

1483 liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed

1484 return (sln, subscribed)

1485

1486−cleanupMergeSubscribed :: MergeSubscribed k -> IO ()

1486+cleanupMergeSubscribed :: MergeSubscribed x k -> IO ()

1487cleanupMergeSubscribed subscribed = do

1488 parents <- readIORef $ mergeSubscribedParents subscribed

1489 forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp

1491 writeIORef (mergeSubscribedCachedSubscribed subscribed) $ Nothing -- Get rid of the cached subscribed

1492

1493{-# INLINE subscribeMergeSubscribed #-}

1494−subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))

1494+subscribeMergeSubscribed :: MergeSubscribed x k -> Subscriber x (DMap k Identity) -> IO (SubscriberListTicket x (DMap k Identity))

1495subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed

1496

1497−{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan k -> Subscriber a -> EventM x (SubscriberListTicket a, FanSubscribed k) #-}

1497+{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (SubscriberListTicket x a, FanSubscribed x k) #-}

1498−getFanSubscribed :: (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m, m ~ EventM x, GCompare k) => k a -> Fan k -> Subscriber a -> m (SubscriberListTicket a, FanSubscribed k)

1498+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (SubscriberListTicket x a, FanSubscribed x k)

1499getFanSubscribed k f sub = do

1500 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1501 case mSubscribed of

1525 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1526 return (slnForSub, subscribed)

1527

1528−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()

1528+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()

1529cleanupFanSubscribed (k, subscribed) = do

1530 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1531 let reducedSubscribers = DMap.delete k subscribers

1537 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1538

1539{-# INLINE subscribeFanSubscribed #-}

1540−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed k -> Subscriber a -> IO (SubscriberListTicket a)

1540+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO (SubscriberListTicket x a)

1541subscribeFanSubscribed k subscribed sub = do

1542 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1543 case DMap.lookup k subscribers of

1549 return sln

1550 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1551

1552−{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}

1552+{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (SubscriberListTicket x a, SwitchSubscribed x a) #-}

1553−getSwitchSubscribed :: (Defer SomeHoldInit m, Defer SomeAssignment m, Defer SomeMergeInit m, Defer SomeClear m, Defer SomeResetCoincidence m, HasCurrentHeight m, HasSpiderEnv x m, m ~ EventM x) => Switch a -> Subscriber a -> m (SubscriberListTicket a, SwitchSubscribed a)

1553+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderEnv x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (SubscriberListTicket x a, SwitchSubscribed x a)

1554getSwitchSubscribed s sub = do

1555 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1556 case mSubscribed of

1595 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed

1596 return (slnForSub, subscribed)

1597

1598−cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()

1598+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()

1599cleanupSwitchSubscribed subscribed = do

1600 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)

1601 finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead

1602 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing

1603

1604{-# INLINE subscribeSwitchSubscribed #-}

1605−subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)

1605+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO (SubscriberListTicket x a)

1606subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1607

1608−{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}

1608+{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (SubscriberListTicket x a, CoincidenceSubscribed x a) #-}

1609−getCoincidenceSubscribed :: forall x a m. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m, m ~ EventM x) => Coincidence a -> Subscriber a -> m (SubscriberListTicket a, CoincidenceSubscribed a)

1609+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderEnv x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (SubscriberListTicket x a, CoincidenceSubscribed x a)

1610getCoincidenceSubscribed c sub = do

1611 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1612 case mSubscribed of

1650 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1651 return (slnForSub, subscribed)

1652

1653−cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()

1653+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()

1654cleanupCoincidenceSubscribed subscribed = do

1655 unsubscribe $ coincidenceSubscribedOuterParent subscribed

1656 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing

1657

1658{-# INLINE subscribeCoincidenceSubscribed #-}

1659−subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)

1659+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO (SubscriberListTicket x a)

1660subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1661

1662{-# INLINE merge #-}

1663−merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)

1663+merge :: GCompare k => Dynamic x R.PatchDMap (DMap k (Event x)) -> Event x (DMap k Identity)

1664merge m = eventMerge $ Merge

1665 { mergeParents = m

1666 , mergeSubscribed = unsafeNewIORef m Nothing

1667 }

1668

1669−newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }

1669+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

1670

1671−fan :: GCompare k => Event (DMap k Identity) -> EventSelector k

1671+fan :: GCompare k => Event x (DMap k Identity) -> EventSelector x k

1672fan e =

1673 let f = Fan

1674 { fanParent = e

1676 }

1677 in EventSelector $ \k -> eventFan k f

1678

1679−runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()

1679+runHoldInits :: IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()

1680runHoldInits holdInitRef mergeInitRef = do

1681 holdInits <- liftIO $ readIORef holdInitRef

1682 mergeInits <- liftIO $ readIORef mergeInitRef

1687 mapM_ initMerge mergeInits

1688 runHoldInits holdInitRef mergeInitRef

1689

1690−initHold :: SomeHoldInit -> EventM x ()

1690+initHold :: SomeHoldInit x -> EventM x ()

1691initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1692

1693−initMerge :: SomeMergeInit -> EventM x ()

1693+initMerge :: SomeMergeInit x -> EventM x ()

1694initMerge (SomeMergeInit subscribed changed) = do

1695 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1696 EventSubscription _ changeSubd <- subscribe changed changeSub

1699 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)

1700

1701-- | Run an event action outside of a frame

1702−runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1702+runFrame :: forall x a. EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1703runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1704 -- Clear out pending unsubscriptions; these will need to happen eventually anyway, and might cause us a lot of extra work during the frame, so get rid of them now

1705 pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)

1732 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1733 mergeUpdates <- readIORef mergeUpdateRef

1734 writeIORef mergeUpdateRef []

1735− let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]

1735+ let updateMerge :: SomeMergeUpdate x -> IO [SomeEventSubscription x]

1736− updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k Event)) m) = do

1736+ updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k (Event x))) m) = do

1737 oldParents <- readIORef $ mergeSubscribedParents m

1738 let f (subscriptionsToKill, ps) (k :=> Compose me) = do

1739 (mOldSubd, newPs) <- case me of

1823 then invalidHeight

1824 else Height $ succ a

1825

1826−invalidateSubscriberHeight :: Height -> Subscriber a -> IO ()

1826+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

1827invalidateSubscriberHeight old s = case s of

1828 SubscriberPush _ subscribed -> do

1829 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed

1859 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

1860 SubscriberHandle -> return ()

1861

1862−removeMergeHeight :: Height -> MergeSubscribed k -> IO ()

1862+removeMergeHeight :: Height -> MergeSubscribed x k -> IO ()

1863removeMergeHeight oldParentHeight subscribed = do

1864 when debugInvalidateHeight $ putStrLn $ "removeMergeHeight: " <> show oldParentHeight <> " Merge" <> showNodeId subscribed

1865 oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed

1866 let newHeights = heightBagRemove oldParentHeight oldHeights

1867 writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights

1868

1869−invalidateMergeHeight :: MergeSubscribed k -> IO ()

1869+invalidateMergeHeight :: MergeSubscribed x k -> IO ()

1870invalidateMergeHeight subscribed = do

1871 oldHeight <- readIORef $ mergeSubscribedHeight subscribed

1872 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1874 writeIORef (mergeSubscribedHeight subscribed) $! invalidHeight

1875 WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1876

1877−addMergeHeight :: Height -> MergeSubscribed k -> IO ()

1877+addMergeHeight :: Height -> MergeSubscribed x k -> IO ()

1878addMergeHeight newParentHeight subscribed = do

1879 when debugInvalidateHeight $ putStrLn $ "addMergeHeight: " <> show newParentHeight <> " Merge" <> showNodeId subscribed

1880 oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed

1881 let newHeights = heightBagAdd newParentHeight oldHeights

1882 writeIORef (mergeSubscribedHeightBag subscribed) $! newHeights

1883

1884−revalidateMergeHeight :: MergeSubscribed k -> IO ()

1884+revalidateMergeHeight :: MergeSubscribed x k -> IO ()

1885revalidateMergeHeight subscribed = do

1886 currentHeight <- readIORef $ mergeSubscribedHeight subscribed

1887 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1897 WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

1898 GT -> error $ "revalidateMergeHeight: more heights than parents for Merge" <> showNodeId subscribed

1899

1900−invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()

1900+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

1901invalidateCoincidenceHeight subscribed = do

1902 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1903 when (oldHeight /= invalidHeight) $ do

1904 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

1905 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1906

1907−recalculateSubscriberHeight :: Height -> Subscriber a -> IO ()

1907+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

1908recalculateSubscriberHeight new s = case s of

1909 SubscriberPush _ subscribed -> do

1910 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed

1937 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

1938 SubscriberHandle -> return ()

1939

1940−updateSwitchHeight :: Height -> SwitchSubscribed a -> IO ()

1940+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

1941updateSwitchHeight new subscribed = do

1942 oldHeight <- readIORef $ switchSubscribedHeight subscribed

1943 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1945 writeIORef (switchSubscribedHeight subscribed) $! new

1946 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

1947

1948−recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()

1948+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

1949recalculateCoincidenceHeight subscribed = do

1950 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1951 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1954 writeIORef (coincidenceSubscribedHeight subscribed) $! height

1955 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

1956

1957−calculateSwitchHeight :: SwitchSubscribed a -> IO Height

1957+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

1958calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

1959

1960−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height

1960+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height

1961calculateCoincidenceHeight subscribed = do

1962 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

1963 innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)

1964 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight

1965

1966−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)

1966+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)

1967

1968−invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)

1968+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))

1969invalidate toReconnectRef wis = do

1970 forM_ wis $ \wi -> do

1971 mi <- deRefWeak wi

2004-- | Stores all global data relevant to a particular Spider timeline; only one

2005-- value should exist for each type @x@

2006data SpiderEnv x = SpiderEnv

2007− { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription])

2007+ { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription x])

2008 , _spiderEnv_lock :: !(MVar ())

2009 , _spiderEnv_cleanups :: !(IORef [IO ()])

2010#ifdef DEBUG

2014type role SpiderEnv nominal

2015

2016instance GEq SpiderEnv where

2017− a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b

2017+ a `geq` b = if _spiderEnv_lock a == _spiderEnv_lock b

2018 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderEnv can't have two different 'x' arguments

2019 else Nothing

2020

2039newSpiderEnv :: IO (Some SpiderEnv)

2040newSpiderEnv = Some.This <$> unsafeNewSpiderEnv

2041

2042−newtype SpiderPullM x a = SpiderPullM (BehaviorM a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2042+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2043

2044−newtype SpiderPushM x a = SpiderPushM (ComputeM a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2044+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2045

2046instance R.Reflex (SpiderEnv x) where

2047− newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }

2047+ newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2048− newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event a }

2048+ newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event x a }

2049− newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)

2049+ newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x Identity a } deriving (Functor, Applicative, Monad)

2050− newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }

2050+ newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic x p a }

2051 type PullM (SpiderEnv x) = SpiderPullM x

2052 type PushM (SpiderEnv x) = SpiderPushM x

2053 {-# INLINABLE never #-}

2059 {-# INLINABLE pull #-}

2060 pull = SpiderBehavior . pull . coerce

2061 {-# INLINABLE merge #-}

2062− merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k Event)

2062+ merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k (Event x))

2063 {-# INLINABLE fan #-}

2064 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

2065 {-# INLINABLE switch #-}

2066− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event (SpiderEnv x) a) -> Behavior (Event a)) . unSpiderBehavior

2066+ switch = SpiderEvent . switch . (unsafeCoerce :: Behavior x (R.Event (SpiderEnv x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2067 {-# INLINABLE coincidence #-}

2068− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event (SpiderEnv x) a) -> Event (Event a)) . unSpiderEvent

2068+ coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event x (R.Event (SpiderEnv x) a) -> Event x (Event x a)) . unSpiderEvent

2069 {-# INLINABLE current #-}

2070 current = SpiderBehavior . current . unSpiderDynamic

2071 {-# INLINABLE updated #-}

2075 {-# INLINABLE unsafeBuildIncremental #-}

2076 unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

2077 {-# INLINABLE mergeIncremental #-}

2078− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic R.PatchDMap (DMap k Event)) . unSpiderIncremental

2078+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic x R.PatchDMap (DMap k (Event x))) . unSpiderIncremental

2079 {-# INLINABLE currentIncremental #-}

2080 currentIncremental = SpiderBehavior . current . unSpiderIncremental

2081 {-# INLINABLE updatedIncremental #-}

2134 {-# INLINABLE holdIncremental #-}

2135 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . DynamicHold <$> hold v0 e

2136

2137−data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)

2137+data RootTrigger x a = forall k. GCompare k => RootTrigger (SubscriberList x a, IORef (DMap k Identity), k a)

2138−newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }

2138+newtype SpiderEventHandle x a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription x a }

2139

2140instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where

2141 {-# INLINABLE subscribeEvent #-}

2144 return $ SpiderEventHandle subscription

2145

2146instance R.ReflexHost (SpiderEnv x) where

2147− type EventTrigger (SpiderEnv x) = RootTrigger

2147+ type EventTrigger (SpiderEnv x) = RootTrigger x

2148− type EventHandle (SpiderEnv x) = SpiderEventHandle

2148+ type EventHandle (SpiderEnv x) = SpiderEventHandle x

2149 type HostFrame (SpiderEnv x) = SpiderHostFrame x

2150

2151instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2202instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where

2203 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2204

2205−addIdentity :: Event a -> Event (Identity a)

2205+addIdentity :: Event x a -> Event x (Identity a)

2206--addIdentity = fmap Identity

2207addIdentity = unsafeCoerce

2208

2214 {-# INLINABLE holdIncremental #-}

2215 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e

2216

2217−newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)

2217+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2218newEventWithTriggerIO f = do

2219 es <- newFanEventWithTriggerIO $ \Refl -> f

2220 return $ select es Refl

2221

2222−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)

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

2223newFanEventWithTriggerIO f = do

2224 occRef <- newIORef DMap.empty

2225 subscribedRef <- newIORef DMap.empty