src/Reflex/Spider/Internal.hs · reflex

git.iko.soy/reflex

on structs2 help sign in

reflex/src/Reflex/Spider/Internal.hs

2222 lines 104 kB history raw

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE ConstraintKinds #-}

4{-# LANGUAGE EmptyDataDecls #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GADTs #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10{-# LANGUAGE LambdaCase #-}

11{-# LANGUAGE MagicHash #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE MultiWayIf #-}

14{-# LANGUAGE RankNTypes #-}

15{-# LANGUAGE RoleAnnotations #-}

16{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

20{-# LANGUAGE MagicHash #-}

21{-# LANGUAGE UnboxedTuples #-}

22-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

23-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

24module Reflex.Spider.Internal where

26import Control.Applicative

27import Control.Concurrent

28import Control.Exception

29import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

30import Control.Monad.Exception

31import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)

32import Control.Monad.Primitive

33import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)

34import Control.Monad.Ref

35import Data.Align

36import Data.Coerce

37import Data.Dependent.Map (DMap, DSum (..))

38import qualified Data.Dependent.Map as DMap

39import Data.Foldable hiding (concat, elem, sequence_)

40import Data.Function

41import Data.Functor.Constant

42import Data.Functor.Product

43import Data.GADT.Compare

44import Data.IntMap.Strict (IntMap)

45import qualified Data.IntMap.Strict as IntMap

46import Data.IORef

47import Data.List hiding (foldl')

48import Data.Maybe

49import Data.Monoid ((<>))

50import Data.Some (Some)

51import qualified Data.Some as Some

52import Data.Struct

53import Data.These

54import Data.Traversable

55import Data.Type.Coercion

56import Data.Word

57import GHC.Exts

58import GHC.IORef (IORef (..))

59import GHC.Stack

60import System.IO.Unsafe

61import System.Mem.Weak

62import Unsafe.Coerce

63import GHC.IO (IO (..))

65#ifdef DEBUG_CYCLES

66import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

67import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

68import qualified Data.List.NonEmpty as NonEmpty

69import Data.Monoid (mempty)

70import Data.Tree (Forest, Tree (..), drawForest)

71#endif

73import Data.WeakBag (WeakBag, WeakBagTicket)

74import qualified Data.WeakBag as WeakBag

75import qualified Reflex.Class as R

76import qualified Reflex.Host.Class as R

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

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

81debugPropagate :: Bool

83debugInvalidateHeight :: Bool

85debugInvalidate :: Bool

87#ifdef DEBUG

89#define DEBUG_NODEIDS

91debugPropagate = True

93debugInvalidateHeight = False

95debugInvalidate = True

97class HasNodeId a where

98 getNodeId :: a -> Int

100instance HasNodeId (Hold x p a) where

101 getNodeId = holdNodeId

102

103instance HasNodeId (PushSubscribed x a b) where

104 getNodeId = pushSubscribedNodeId

105

106instance HasNodeId (SwitchSubscribed x a) where

107 getNodeId = switchSubscribedNodeId

108

109instance HasNodeId (FanSubscribed x a) where

110 getNodeId = fanSubscribedNodeId

111

112instance HasNodeId (CoincidenceSubscribed x a) where

113 getNodeId = coincidenceSubscribedNodeId

114

115instance HasNodeId (RootSubscribed x a) where

116 getNodeId = rootSubscribedNodeId

117

118instance HasNodeId (Pull x a) where

119 getNodeId = pullNodeId

120

121{-# INLINE showNodeId #-}

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

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

124

125showSubscriberType :: Subscriber x a -> String

126showSubscriberType = \case

127 SubscriberPush _ _ -> "SubscriberPush"

128 SubscriberMerge _ _ -> "SubscriberMerge"

129 SubscriberFan _ -> "SubscriberFan"

130 SubscriberMergeChange _ -> "SubscriberMergeChange"

131 SubscriberHold _ -> "SubscriberHold"

132 SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"

133 SubscriberSwitch _ -> "SubscriberSwitch"

134 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"

135 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

136 SubscriberHandle -> "SubscriberHandle"

137

138showEventType :: Event x a -> String

139showEventType = \case

140 EventRoot _ _ -> "EventRoot"

141 EventNever -> "EventNever"

142 EventPush _ -> "EventPush"

143 EventMerge _ -> "EventMerge"

144 EventFan _ _ -> "EventFan"

145 EventSwitch _ -> "EventSwitch"

146 EventCoincidence _ -> "EventCoincidence"

147 EventHold _ -> "EventHold"

148 EventDyn _ -> "EventDyn"

149 EventHoldIdentity _ -> "EventHoldIdentity"

150 EventDynIdentity _ -> "EventDynIdentity"

151

152#else

153

154debugPropagate = False

155

156debugInvalidateHeight = False

157

158debugInvalidate = False

159

160-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

161{-# INLINE showNodeId #-}

162showNodeId :: a -> String

163showNodeId _ = ""

164

165#endif

166

167#ifdef DEBUG_NODEIDS

168{-# NOINLINE nextNodeIdRef #-}

169nextNodeIdRef :: IORef Int

170nextNodeIdRef = unsafePerformIO $ newIORef 1

171

172newNodeId :: IO Int

173newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

174

175{-# NOINLINE unsafeNodeId #-}

176unsafeNodeId :: a -> Int

177unsafeNodeId a = unsafePerformIO $ do

178 touch a

179 newNodeId

180#endif

181

182--------------------------------------------------------------------------------

183-- Event

184--------------------------------------------------------------------------------

185

186newtype Event x a = Event { subscribeAndRead :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }

187

188-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

189-- caching; if the computation function is very cheap, this is (much) more

190-- efficient than 'push'

191{-# INLINABLE pushCheap #-}

192pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

193pushCheap f e = Event $ \sub -> do

194 (subscription, occ) <- subscribeAndRead e $ sub

195 { subscriberPropagate = \a -> do

196 mb <- runComputeM $ f a

197 mapM_ (subscriberPropagate sub) mb

198 }

199 occ' <- join <$> mapM (runComputeM . f) occ

200 return (subscription, occ')

201

202{-

203data CacheSubscribed x a

204 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))

205 , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))

206 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

207 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

208 , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))

209 }

210-}

211

212newtype EventCache x a s = EventCache (Object s) deriving Struct

213

214allocEventCache :: PrimMonad m => m (EventCache x a (PrimState m))

215allocEventCache = alloc 4

216

217{-# NOINLINE unsafeAllocEventCache #-}

218unsafeAllocEventCache :: q -> EventCache x a (PrimState IO)

219unsafeAllocEventCache q = unsafePerformIO $ do

220 touch q

221 c <- allocEventCache

222 set eventCache_subscribers_slot c Nil -- We only need to initialize this one; the others will be initialized later

223 return c

224

225clearEventCache :: EventCache x a (PrimState IO) -> IO ()

226clearEventCache c = do

227 set eventCache_subscribers_slot c Nil

228 setField eventCache_weakSelf c $ error "weakSelf has been cleared"

229 setField eventCache_parent c $ error "parent has been cleared"

230 set eventCache_occurrence_slot c Nil

231

232eventCache_subscribers :: Field (EventCache x a) (WeakBag (Subscriber x a))

233eventCache_subscribers = field 0

234

235eventCache_subscribers_slot :: Slot (EventCache x a) Object

236eventCache_subscribers_slot = slot 0

237

238eventCache_weakSelf :: Field (EventCache x a) (Weak (EventCache x a s))

239eventCache_weakSelf = field 1

240

241eventCache_parent :: Field (EventCache x a) (EventSubscription x)

242eventCache_parent = field 2

243

244eventCache_occurrence :: Field (EventCache x a) a

245eventCache_occurrence = field 3

246

247eventCache_occurrence_slot :: Slot (EventCache x a) Object

248eventCache_occurrence_slot = slot 3

249

250freezeStruct :: Struct t => t (PrimState IO) -> IO ()

251freezeStruct t = IO $ \s -> case unsafeFreezeSmallArray# (destruct t) s of

252 (# s', _ #) -> (# s', () #)

253

254thawStruct :: Struct t => t (PrimState IO) -> IO ()

255thawStruct t = IO $ \s -> case unsafeThawSmallArray# (unsafeCoerce# (destruct t)) s of

256 (# s', _ #) -> (# s', () #)

257

258-- | Construct an 'Event' whose value is guaranteed not to be recomputed

259-- repeatedly

260--

261--TODO: Try a caching strategy where we subscribe directly to the parent when

262--there's only one subscriber, and then build our own WeakBag only when a second

263--subscriber joins

264{-# INLINABLE cacheEvent #-}

265cacheEvent :: Event x a -> Event x a

266cacheEvent e = let !c = unsafeAllocEventCache e in Event $ \sub -> {-# SCC "cacheEvent" #-} do

267 subscribersNil <- liftIO $ get eventCache_subscribers_slot c

268 case isNil subscribersNil of

269 False -> liftIO $ {-# SCC "cacheEventFalse" #-} do

270 subscribers <- getField eventCache_subscribers c

271 weakSelf <- getField eventCache_weakSelf c

272 weakSelfRef <- newIORef weakSelf --TODO: Get rid of this extraneous IORef

273 ticket <- WeakBag.insert sub subscribers weakSelfRef cleanupCacheSubscribed

274 occNil <- get eventCache_occurrence_slot c

275 occ <- if isNil occNil

276 then return Nothing

277 else Just <$> getField eventCache_occurrence c

278 let es = EventSubscribed

279 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ unsafeDupablePerformIO $ getField eventCache_parent c

280 , eventSubscribedRetained = toAny c

281 }

282 return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)

283 True -> {-# SCC "cacheEventTrue" #-} do

284 weakSelf <- liftIO $ evaluate =<< mkWeakPtrWithDebug c "CacheEvent"

285 liftIO $ setField eventCache_weakSelf c weakSelf

286 weakSelfRef <- liftIO $ newIORef weakSelf --TODO: Get rid of this extraneous IORef

287 (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelfRef cleanupCacheSubscribed

288 liftIO $ setField eventCache_subscribers c subscribers

289 (parentSub, occ) <- subscribeAndRead e $ Subscriber

290 { subscriberPropagate = \a -> do

291-- liftIO $ thawStruct c

292 liftIO $ setField eventCache_occurrence c a

293-- liftIO $ freezeStruct c

294 scheduleClearEventCache c

295 propagate a subscribers

296 , subscriberInvalidateHeight = \old -> do

297 WeakBag.traverse subscribers $ invalidateSubscriberHeight old

298 , subscriberRecalculateHeight = \new -> do

299 WeakBag.traverse subscribers $ recalculateSubscriberHeight new

300 }

301 liftIO $ setField eventCache_parent c parentSub

302 case occ of

303 Nothing -> liftIO $ set eventCache_occurrence_slot c Nil

304 Just o -> do

305 liftIO $ setField eventCache_occurrence c o

306 scheduleClearEventCache c

307-- liftIO $ freezeStruct c

308 return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny c)), occ)

309

310{-# INLINE scheduleClearEventCache #-}

311scheduleClearEventCache :: Defer (SomeClearEventCache x) m => EventCache x a (PrimState IO) -> m ()

312scheduleClearEventCache r = defer $ SomeClearEventCache r

313

314cleanupCacheSubscribed :: EventCache x a (PrimState IO) -> IO ()

315cleanupCacheSubscribed self = do

316 parent <- getField eventCache_parent self

317 unsubscribe parent

318 clearEventCache self

319

320subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

321subscribe e s = fst <$> subscribeAndRead e s

322

323{-# INLINE wrap #-}

324wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)

325wrap tag getSpecificSubscribed sub = do

326 (sln, subd, occ) <- getSpecificSubscribed sub

327 let es = tag subd

328 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

329

330eventRoot :: GCompare k => k a -> Root x k -> Event x a

331eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

332

333eventNever :: Event x a

334eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)

335

336eventFan :: GCompare k => k a -> Fan x k -> Event x a

337eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

338

339eventSwitch :: Switch x a -> Event x a

340eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

341

342eventCoincidence :: Coincidence x a -> Event x a

343eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

344

345eventHold :: Hold x p -> Event x p

346eventHold !h = Event $ subscribeHoldEvent h

347

348eventDyn :: R.Patch p => Dyn x p -> Event x p

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

350

351{-# INLINE subscribeCoincidenceInner #-}

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

353subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

354 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

355 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

356 innerHeight <- liftIO $ getEventSubscribedHeight innerSubd

357 let height = max innerHeight outerHeight

358 defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing

359 return (innerOcc, height, innerSubd)

360

361--------------------------------------------------------------------------------

362-- Subscriber

363--------------------------------------------------------------------------------

364

365data Subscriber x a = Subscriber

366 { subscriberPropagate :: !(a -> EventM x ())

367 , subscriberInvalidateHeight :: !(Height -> IO ())

368 , subscriberRecalculateHeight :: !(Height -> IO ())

369 }

370

371--TODO: Move this comment to WeakBag

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

373-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away

374-- so any weak references that are attached to the constructors will have their

375-- finalizer run. Using the opaque constructor, does not see the

376-- constructor application, so it behaves like an IORef and cannot be fused away.

377--

378-- The result is also evaluated to WHNF, since forcing a thunk invalidates

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

380

381newSubscriberHold :: R.Patch p => Hold x p -> IO (Subscriber x p)

382newSubscriberHold h = return $ Subscriber

383 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

384 , subscriberInvalidateHeight = \_ -> return ()

385 , subscriberRecalculateHeight = \_ -> return ()

386 }

387

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

389newSubscriberFan subscribed = return $ Subscriber

390 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

391 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

392 tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

393 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

394 scheduleClear $ fanSubscribedOccurrence subscribed

395 let f _ (Pair (Identity v) subsubs) = do

396 propagate v $ _fanSubscribedChildren_list subsubs

397 return $ Constant ()

398 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

399 return ()

400 , subscriberInvalidateHeight = \old -> do

401 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

402 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

403 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

404 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

405 , subscriberRecalculateHeight = \new -> do

406 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

407 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

408 forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

409 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

410 }

411

412newSubscriberSwitch :: SwitchSubscribed x a -> IO (Subscriber x a)

413newSubscriberSwitch subscribed = return $ Subscriber

414 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

415 tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed

416 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

417 scheduleClear $ switchSubscribedOccurrence subscribed

418 propagate a $ switchSubscribedSubscribers subscribed

419 , subscriberInvalidateHeight = \_ -> do

420 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

421 oldHeight <- readIORef $ switchSubscribedHeight subscribed

422 when (oldHeight /= invalidHeight) $ do

423 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

424 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

425 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

426 , subscriberRecalculateHeight = \new -> do

427 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

428 updateSwitchHeight new subscribed

429 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

430 }

431

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

433newSubscriberCoincidenceOuter subscribed = return $ Subscriber

434 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

435 tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

436 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

437 tracePropagate $ " outerHeight = " <> show outerHeight

438 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

439 tracePropagate $ " isJust occ = " <> show (isJust occ)

440 tracePropagate $ " innerHeight = " <> show innerHeight

441 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

442 scheduleClear $ coincidenceSubscribedInnerParent subscribed

443 case occ of

444 Nothing -> do

445 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

446 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

447 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

448 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

449 Just o -> do -- Since it's already firing, no need to adjust height

450 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

451 scheduleClear $ coincidenceSubscribedOccurrence subscribed

452 propagate o $ coincidenceSubscribedSubscribers subscribed

453 , subscriberInvalidateHeight = \_ -> do

454 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

455 invalidateCoincidenceHeight subscribed

456 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

457 , subscriberRecalculateHeight = \_ -> do

458 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

459 recalculateCoincidenceHeight subscribed

460 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

461 }

462

463newSubscriberCoincidenceInner :: CoincidenceSubscribed x a -> IO (Subscriber x a)

464newSubscriberCoincidenceInner subscribed = return $ Subscriber

465 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

466 tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed

467 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

468 case occ of

469 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

470 Nothing -> do

471 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

472 scheduleClear $ coincidenceSubscribedOccurrence subscribed

473 propagate a $ coincidenceSubscribedSubscribers subscribed

474 , subscriberInvalidateHeight = \_ -> do

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

476 invalidateCoincidenceHeight subscribed

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

478 , subscriberRecalculateHeight = \_ -> do

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

480 recalculateCoincidenceHeight subscribed

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

482 }

483

484invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

485invalidateSubscriberHeight = flip subscriberInvalidateHeight

486

487recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

488recalculateSubscriberHeight = flip subscriberRecalculateHeight

489

490-- | Propagate everything at the current height

491propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

492propagate a subscribers = withIncreasedDepth $ do

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

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

495 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

496

497--------------------------------------------------------------------------------

498-- EventSubscribed

499--------------------------------------------------------------------------------

500

501toAny :: a -> Any

502toAny = unsafeCoerce

503

504data EventSubscribed x = EventSubscribed

505 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

506 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

507#ifdef DEBUG_CYCLES

508 , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

509 , eventSubscribedHasOwnHeightRef :: !Bool

510 , eventSubscribedWhoCreated :: !(IO [String])

511#endif

512 }

513

514eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x

515eventSubscribedRoot !r = EventSubscribed

516 { eventSubscribedHeightRef = zeroRef

517 , eventSubscribedRetained = toAny r

518#ifdef DEBUG_CYCLES

519 , eventSubscribedGetParents = return []

520 , eventSubscribedHasOwnHeightRef = False

521 , eventSubscribedWhoCreated = return ["root"]

522#endif

523 }

524

525eventSubscribedNever :: EventSubscribed x

526eventSubscribedNever = EventSubscribed

527 { eventSubscribedHeightRef = zeroRef

528 , eventSubscribedRetained = toAny ()

529#ifdef DEBUG_CYCLES

530 , eventSubscribedGetParents = return []

531 , eventSubscribedHasOwnHeightRef = False

532 , eventSubscribedWhoCreated = return ["never"]

533#endif

534 }

535

536eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x

537eventSubscribedFan !subscribed = EventSubscribed

538 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

539 , eventSubscribedRetained = toAny subscribed

540#ifdef DEBUG_CYCLES

541 , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

542 , eventSubscribedHasOwnHeightRef = False

543 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

544#endif

545 }

546

547eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x

548eventSubscribedSwitch !subscribed = EventSubscribed

549 { eventSubscribedHeightRef = switchSubscribedHeight subscribed

550 , eventSubscribedRetained = toAny subscribed

551#ifdef DEBUG_CYCLES

552 , eventSubscribedGetParents = do

553 s <- readIORef $ switchSubscribedCurrentParent subscribed

554 return [Some.This $ _eventSubscription_subscribed s]

555 , eventSubscribedHasOwnHeightRef = True

556 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

557#endif

558 }

559

560eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x

561eventSubscribedCoincidence !subscribed = EventSubscribed

562 { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed

563 , eventSubscribedRetained = toAny subscribed

564#ifdef DEBUG_CYCLES

565 , eventSubscribedGetParents = do

566 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

567 let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

568 innerParents = maybeToList $ fmap Some.This innerSubscription

569 return $ outerParent : innerParents

570 , eventSubscribedHasOwnHeightRef = True

571 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

572#endif

573 }

574

575getEventSubscribedHeight :: EventSubscribed x -> IO Height

576getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

577

578#ifdef DEBUG_CYCLES

579whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

580whoCreatedEventSubscribed = eventSubscribedWhoCreated

581

582walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]

583walkInvalidHeightParents s0 = do

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

585 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

586 when (h == invalidHeight) $ do

587 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

588 modify (Some.This s :)

589 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

590 forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

591 return subscribers

592#endif

593

594{-# INLINE subscribeHoldEvent #-}

595subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)

596subscribeHoldEvent = subscribeAndRead . holdEvent

597

598--------------------------------------------------------------------------------

599-- EventSubscription

600--------------------------------------------------------------------------------

601

602data EventSubscription x = EventSubscription

603 { _eventSubscription_unsubscribe :: !(IO ())

604 , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)

605 }

606

607unsubscribe :: EventSubscription x -> IO ()

608unsubscribe (EventSubscription u _) = u

609

610--------------------------------------------------------------------------------

611-- Behavior

612--------------------------------------------------------------------------------

613

614newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }

615

616behaviorHold :: Hold x p -> Behavior x (R.PatchTarget p)

617behaviorHold !h = Behavior $ readHoldTracked h

618

619behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a

620behaviorHoldIdentity = behaviorHold

621

622behaviorConst :: a -> Behavior x a

623behaviorConst !a = Behavior $ return a

624

625behaviorPull :: Pull x a -> Behavior x a

626behaviorPull !p = Behavior $ do

627 val <- liftIO $ readIORef $ pullValue p

628 case val of

629 Just subscribed -> do

630 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

631 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

632 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

633 return $ pullSubscribedValue subscribed

634 Nothing -> do

635 i <- liftIO $ newInvalidatorPull p

636 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

637 parentsRef <- liftIO $ newIORef []

638 holdInits <- askBehaviorHoldInits

639 a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

640 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

641 parents <- liftIO $ readIORef parentsRef

642 let subscribed = PullSubscribed

643 { pullSubscribedValue = a

644 , pullSubscribedInvalidators = invsRef

645 , pullSubscribedOwnInvalidator = i

646 , pullSubscribedParents = parents

647 }

648 liftIO $ writeIORef (pullValue p) $ Just subscribed

649 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

650 return a

651

652behaviorDyn :: R.Patch p => Dyn x p -> Behavior x (R.PatchTarget p)

653behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d

654

655{-# INLINE readHoldTracked #-}

656readHoldTracked :: Hold x p -> BehaviorM x (R.PatchTarget p)

657readHoldTracked h = do

658 result <- liftIO $ readIORef $ holdValue h

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

660 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

661 return result

662

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

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

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

666readBehaviorUntracked b = do

667 holdInits <- getDeferralQueue

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

669

670--------------------------------------------------------------------------------

671-- Dynamic

672--------------------------------------------------------------------------------

673

674data Dynamic x p = Dynamic

675 { dynamicCurrent :: !(Behavior x (R.PatchTarget p))

676 , dynamicUpdated :: !(Event x p)

677 }

678

679dynamicHold :: Hold x p -> Dynamic x p

680dynamicHold !h = Dynamic

681 { dynamicCurrent = behaviorHold h

682 , dynamicUpdated = eventHold h

683 }

684

685dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

686dynamicHoldIdentity = dynamicHold

687

688dynamicConst :: R.PatchTarget p -> Dynamic x p

689dynamicConst !a = Dynamic

690 { dynamicCurrent = behaviorConst a

691 , dynamicUpdated = eventNever

692 }

693

694dynamicDyn :: R.Patch p => Dyn x p -> Dynamic x p

695dynamicDyn !d = Dynamic

696 { dynamicCurrent = behaviorDyn d

697 , dynamicUpdated = eventDyn d

698 }

699

700dynamicDynIdentity :: Dyn x (Identity a) -> Dynamic x (Identity a)

701dynamicDynIdentity = dynamicDyn

702

703--------------------------------------------------------------------------------

704-- Combinators

705--------------------------------------------------------------------------------

706

707--TODO: Figure out why certain things are not 'representational', then make them

708--representational so we can use coerce

709

710--type role Hold representational

711data Hold x p

712 = Hold { holdValue :: !(IORef (R.PatchTarget p))

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

714 , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events

715 , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef

716#ifdef DEBUG_NODEIDS

717 , holdNodeId :: Int

718#endif

719 }

720

721data EventEnv x

722 = EventEnv { eventEnvSpiderTimeline :: !(SpiderTimeline x)

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

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

725 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

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

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

728 , eventEnvClearEventCaches :: !(IORef [SomeClearEventCache x]) -- Needed for Subscribe

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

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

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

732 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))

733 }

734

735{-# INLINE runEventM #-}

736runEventM :: EventM x a -> EventEnv x -> IO a

737runEventM = runReaderT . unEventM

738

739class MonadIO m => Defer a m where

740 getDeferralQueue :: m (IORef [a])

741

742{-# INLINE defer #-}

743defer :: Defer a m => a -> m ()

744defer a = do

745 q <- getDeferralQueue

746 liftIO $ modifyIORef' q (a:)

747

748instance Defer (SomeAssignment x) (EventM x) where

749 {-# INLINE getDeferralQueue #-}

750 getDeferralQueue = EventM $ asks eventEnvAssignments

751

752instance Defer (SomeHoldInit x) (EventM x) where

753 {-# INLINE getDeferralQueue #-}

754 getDeferralQueue = EventM $ asks eventEnvHoldInits

755

756instance Defer (SomeHoldInit x) (BehaviorM x) where

757 {-# INLINE getDeferralQueue #-}

758 getDeferralQueue = BehaviorM $ asks snd

759

760instance Defer (SomeMergeUpdate x) (EventM x) where

761 {-# INLINE getDeferralQueue #-}

762 getDeferralQueue = EventM $ asks eventEnvMergeUpdates

763

764instance Defer (SomeMergeInit x) (EventM x) where

765 {-# INLINE getDeferralQueue #-}

766 getDeferralQueue = EventM $ asks eventEnvMergeInits

767

768class HasCurrentHeight x m | m -> x where

769 getCurrentHeight :: m Height

770 scheduleMerge :: Height -> EventM x () -> m ()

771

772instance HasCurrentHeight x (EventM x) where

773 {-# INLINE getCurrentHeight #-}

774 getCurrentHeight = EventM $ do

775 heightRef <- asks eventEnvCurrentHeight

776 liftIO $ readIORef heightRef

777 {-# INLINE scheduleMerge #-}

778 scheduleMerge height subscribed = EventM $ do

779 delayedRef <- asks eventEnvDelayedMerges

780 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

781

782class HasSpiderTimeline x m | m -> x where

783 -- | Retrieve the current SpiderTimeline

784 askSpiderTimeline :: m (SpiderTimeline x)

785

786instance HasSpiderTimeline x (EventM x) where

787 {-# INLINE askSpiderTimeline #-}

788 askSpiderTimeline = EventM $ asks eventEnvSpiderTimeline

789

790instance HasSpiderTimeline x (SpiderHost x) where

791 {-# INLINE askSpiderTimeline #-}

792 askSpiderTimeline = SpiderHost ask

793

794putCurrentHeight :: Height -> EventM x ()

795putCurrentHeight h = EventM $ do

796 heightRef <- asks eventEnvCurrentHeight

797 liftIO $ writeIORef heightRef $! h

798

799instance Defer SomeClear (EventM x) where

800 {-# INLINE getDeferralQueue #-}

801 getDeferralQueue = EventM $ asks eventEnvClears

802

803instance Defer (SomeClearEventCache x) (EventM x) where

804 {-# INLINE getDeferralQueue #-}

805 getDeferralQueue = EventM $ asks eventEnvClearEventCaches

806

807{-# INLINE scheduleClear #-}

808scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

809scheduleClear r = defer $ SomeClear r

810

811instance Defer SomeRootClear (EventM x) where

812 {-# INLINE getDeferralQueue #-}

813 getDeferralQueue = EventM $ asks eventEnvRootClears

814

815{-# INLINE scheduleRootClear #-}

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

817scheduleRootClear r = defer $ SomeRootClear r

818

819instance Defer (SomeResetCoincidence x) (EventM x) where

820 {-# INLINE getDeferralQueue #-}

821 getDeferralQueue = EventM $ asks eventEnvResetCoincidences

822

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

824{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}

825{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}

826hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)

827hold v0 e = do

828 valRef <- liftIO $ newIORef v0

829 invsRef <- liftIO $ newIORef []

830 parentRef <- liftIO $ newIORef Nothing

831#ifdef DEBUG_NODEIDS

832 nodeId <- liftIO newNodeId

833#endif

834 let h = Hold

835 { holdValue = valRef

836 , holdInvalidators = invsRef

837 , holdEvent = e

838 , holdParent = parentRef

839#ifdef DEBUG_NODEIDS

840 , holdNodeId = nodeId

841#endif

842 }

843 defer $ SomeHoldInit h

844 return h

845

846{-# INLINE getHoldEventSubscription #-}

847getHoldEventSubscription :: forall m p 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, HasSpiderTimeline x m, m ~ EventM x) => Hold x p -> m (EventSubscription x)

848getHoldEventSubscription h = do

849 ep <- liftIO $ readIORef $ holdParent h

850 case ep of

851 Just subd -> return subd

852 Nothing -> do

853 let e = holdEvent h

854 subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"

855 (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)

856 liftIO $ writeIORef subscriptionRef $! subscription

857 case occ of

858 Nothing -> return ()

859 Just o -> do

860 old <- liftIO $ readIORef $ holdValue h

861 case R.apply o old of

862 Nothing -> return ()

863 Just new -> do

864 -- Need to evaluate these so that we don't retain the Hold itself

865 v <- liftIO $ evaluate $ holdValue h

866 i <- liftIO $ evaluate $ holdInvalidators h

867 defer $ SomeAssignment v i new

868 liftIO $ writeIORef (holdParent h) $ Just subscription

869 return subscription

870

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

872

873--type role BehaviorM representational

874-- BehaviorM can sample behaviors

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

876

877instance Monad (BehaviorM x) where

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

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

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

881 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

882 {-# INLINE return #-}

883 return x = BehaviorM $ return x

884 {-# INLINE fail #-}

885 fail s = BehaviorM $ fail s

886

887data BehaviorSubscribed x a

888 = forall p. BehaviorSubscribedHold (Hold x p)

889 | BehaviorSubscribedPull (PullSubscribed x a)

890

891data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)

892

893--type role PullSubscribed representational

894data PullSubscribed x a

895 = PullSubscribed { pullSubscribedValue :: !a

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

897 , pullSubscribedOwnInvalidator :: !(Invalidator x)

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

899 }

900

901--type role Pull representational

902data Pull x a

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

904 , pullCompute :: !(BehaviorM x a)

905#ifdef DEBUG_NODEIDS

906 , pullNodeId :: Int

907#endif

908 }

909

910data Invalidator x

911 = forall a. InvalidatorPull (Pull x a)

912 | forall a. InvalidatorSwitch (SwitchSubscribed x a)

913

914data RootSubscribed x a = forall k. GCompare k => RootSubscribed

915 { rootSubscribedKey :: !(k a)

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

917 , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))

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

919 , rootSubscribedUninit :: IO ()

920 , 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?

921#ifdef DEBUG_NODEIDS

922 , rootSubscribedNodeId :: Int

923#endif

924 }

925

926data Root x (k :: * -> *)

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

928 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

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

930 }

931

932data SomeHoldInit x = forall p. R.Patch p => SomeHoldInit !(Hold x p)

933

934data SomeMergeUpdate x = SomeMergeUpdate

935 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])

936 , _someMergeUpdate_invalidateHeight :: !(IO ())

937 , _someMergeUpdate_recalculateHeight :: !(IO ())

938 }

939

940newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

941

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

943newtype 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

944

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

946

947instance Defer (SomeHoldInit x) (ComputeM x) where

948 getDeferralQueue = ComputeM ask

949

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

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

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

953

954newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

955

956data HeightBag = HeightBag

957 { _heightBag_size :: {-# UNPACK #-} !Int

958 , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket

959 }

960 deriving (Show, Read, Eq, Ord)

961

962heightBagEmpty :: HeightBag

963heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty

964

965heightBagSize :: HeightBag -> Int

966heightBagSize = _heightBag_size

967

968heightBagFromList :: [Height] -> HeightBag

969heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

970

971heightBagAdd :: Height -> HeightBag -> HeightBag

972heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

973

974heightBagRemove :: Height -> HeightBag -> HeightBag

975heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

976 Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b

977 Just old -> HeightBag (pred s) $ case old of

978 0 -> IntMap.delete h c

979 _ -> IntMap.insert h (pred old) c

980

981heightBagMax :: HeightBag -> Height

982heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

983 Just ((h, _), _) -> Height h

984 Nothing -> zeroHeight

985

986heightBagVerify :: HeightBag -> HeightBag

987#ifdef DEBUG

988heightBagVerify b@(HeightBag s c) = if

989 | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))

990 -> error $ "heightBagVerify: size doesn't match: " <> show b

991 | unHeight invalidHeight `IntMap.member` c

992 -> error $ "heightBagVerify: contains invalid height: " <> show b

993 | otherwise -> b

994#else

995heightBagVerify = id

996#endif

997

998data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

999 { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))

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

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

1002 }

1003

1004data FanSubscribed (x :: *) k

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

1006 , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

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

1008 , fanSubscribedParent :: !(EventSubscription x)

1009#ifdef DEBUG_NODEIDS

1010 , fanSubscribedNodeId :: Int

1011#endif

1012 }

1013

1014data Fan x k

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

1016 , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1017 }

1018

1019data SwitchSubscribed x a

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

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

1022 , switchSubscribedHeight :: !(IORef Height)

1023 , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))

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

1025 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))

1026 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])

1027 , switchSubscribedParent :: !(Behavior x (Event x a))

1028 , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))

1029 , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))

1030#ifdef DEBUG_NODEIDS

1031 , switchSubscribedNodeId :: Int

1032#endif

1033 }

1034

1035data Switch x a

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

1037 , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))

1038 }

1039

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

1041data CoincidenceSubscribed x a

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

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

1044 , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))

1045 , coincidenceSubscribedHeight :: !(IORef Height)

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

1047 , coincidenceSubscribedOuterParent :: !(EventSubscription x)

1048 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))

1049 , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))

1050#ifdef DEBUG_NODEIDS

1051 , coincidenceSubscribedNodeId :: Int

1052#endif

1053 }

1054

1055data Coincidence x a

1056 = Coincidence { coincidenceParent :: !(Event x (Event x a))

1057 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))

1058 }

1059

1060{-# NOINLINE newInvalidatorSwitch #-}

1061newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)

1062newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

1063

1064{-# NOINLINE newInvalidatorPull #-}

1065newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1066newInvalidatorPull p = return $! InvalidatorPull p

1067

1068instance R.FunctorMaybe (Event x) where

1069 fmapMaybe f = push $ return . f

1070

1071instance Align (Event x) where

1072 nil = eventNever

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

1074

1075newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (R.PatchTarget p), Event x p) (Hold x p)) }

1076

1077newMapDyn :: (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1078newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1079

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

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

1082zipDynWith f da db =

1083 let eab = align (dynamicUpdated da) (dynamicUpdated db)

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

1085 (a, b) <- case o of

1086 This (Identity a) -> do

1087 b <- readBehaviorUntracked $ dynamicCurrent db

1088 return (a, b)

1089 That (Identity b) -> do

1090 a <- readBehaviorUntracked $ dynamicCurrent da

1091 return (a, b)

1092 These (Identity a) (Identity b) -> return (a, b)

1093 return $ Just $ Identity $ f a b

1094 in dynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1095

1096unsafeDyn :: BehaviorM x (R.PatchTarget p) -> Event x p -> Dyn x p

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

1098 where x = (readV0, v')

1099

1100newJoinDyn :: Dynamic x (Identity (Dynamic x (Identity a))) -> Dyn x (Identity a)

1101newJoinDyn d =

1102 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

1103 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

1104 eInner = switch $ dynamicUpdated <$> dynamicCurrent d

1105 eBoth = coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

1106 v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

1107 in unsafeDyn readV0 v'

1108

1109-- ResultM can read behaviors and events

1110type ResultM = EventM

1111

1112{-# NOINLINE unsafeNewIORef #-}

1113unsafeNewIORef :: a -> b -> IORef b

1114unsafeNewIORef _ b = unsafePerformIO $ newIORef b

1115

1116instance Functor (Event x) where

1117 fmap f = push $ return . Just . f

1118

1119instance Functor (Behavior x) where

1120 fmap f = pull . fmap f . readBehaviorTracked

1121

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

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

1124push f e = cacheEvent (pushCheap f e)

1125{-

1126push f e = eventPush $ Push

1127 { pushCompute = f

1128 , pushParent = e

1129 , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?

1130 }

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

1132-}

1133

1134{-# INLINABLE pull #-}

1135pull :: BehaviorM x a -> Behavior x a

1136pull a = behaviorPull $ Pull

1137 { pullCompute = a

1138 , pullValue = unsafeNewIORef a Nothing

1139#ifdef DEBUG_NODEIDS

1140 , pullNodeId = unsafeNodeId a

1141#endif

1142 }

1143

1144{-# INLINABLE switch #-}

1145switch :: Behavior x (Event x a) -> Event x a

1146switch a = eventSwitch $ Switch

1147 { switchParent = a

1148 , switchSubscribed = unsafeNewIORef a Nothing

1149 }

1150

1151coincidence :: Event x (Event x a) -> Event x a

1152coincidence a = eventCoincidence $ Coincidence

1153 { coincidenceParent = a

1154 , coincidenceSubscribed = unsafeNewIORef a Nothing

1155 }

1156

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

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

1159run roots after = do

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

1161 spiderTimeline <- SpiderHost ask

1162 result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock spiderTimeline) $ \_ -> flip runReaderT spiderTimeline $ unSpiderHost $ runFrame $ do

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

1164 occBefore <- liftIO $ do

1165 occBefore <- readIORef occRef

1166 writeIORef occRef $! DMap.insert k a occBefore

1167 return occBefore

1168 if DMap.null occBefore

1169 then do scheduleRootClear occRef

1170 return $ Just r

1171 else return Nothing

1172 forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do

1173 propagate a subscribersRef

1174 delayedRef <- EventM $ asks eventEnvDelayedMerges

1175 let go = do

1176 delayed <- liftIO $ readIORef delayedRef

1177 case IntMap.minViewWithKey delayed of

1178 Nothing -> return ()

1179 Just ((currentHeight, cur), future) -> do

1180 tracePropagate $ "Running height " ++ show currentHeight

1181 putCurrentHeight $ Height currentHeight

1182 liftIO $ writeIORef delayedRef $! future

1183 sequence_ cur

1184 go

1185 go

1186 putCurrentHeight maxBound

1187 after

1188 tracePropagate "Done running an event frame"

1189 return result

1190

1191scheduleMerge' :: Height -> IORef Height -> EventM x () -> EventM x ()

1192scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

1193 height <- liftIO $ readIORef heightRef

1194 currentHeight <- getCurrentHeight

1195 case height `compare` currentHeight of

1196 LT -> error "Somehow a merge's height has been decreased after it was scheduled"

1197 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1198 EQ -> a

1199

1200data SomeClear = forall a. SomeClear (IORef (Maybe a))

1201

1202data SomeClearEventCache x = forall a. SomeClearEventCache (EventCache x a (PrimState IO))

1203

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

1205

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

1207

1208debugFinalize :: Bool

1209debugFinalize = False

1210

1211mkWeakPtrWithDebug :: a -> String -> IO (Weak a)

1212mkWeakPtrWithDebug x debugNote = do

1213 x' <- evaluate x

1214 mkWeakPtr x' $

1215 if debugFinalize

1216 then Just $ putStrLn $ "finalizing: " ++ debugNote

1217 else Nothing

1218

1219type WeakList a = [Weak a]

1220

1221{-# INLINE withIncreasedDepth #-}

1222#ifdef DEBUG

1223withIncreasedDepth :: CanTrace x m => m a -> m a

1224withIncreasedDepth a = do

1225 spiderTimeline <- askSpiderTimeline

1226 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1227 result <- a

1228 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1229 return result

1230#else

1231withIncreasedDepth :: m a -> m a

1232withIncreasedDepth = id

1233#endif

1234

1235type CanTrace x m = (HasSpiderTimeline x m, MonadIO m)

1236

1237{-# INLINE tracePropagate #-}

1238tracePropagate :: (CanTrace x m) => String -> m ()

1239tracePropagate = traceWhen debugPropagate

1240

1241{-# INLINE traceInvalidate #-}

1242traceInvalidate :: String -> IO ()

1243traceInvalidate = when debugInvalidate . liftIO . putStrLn

1244

1245{-# INLINE traceWhen #-}

1246traceWhen :: (CanTrace x m) => Bool -> String -> m ()

1247traceWhen b message = traceMWhen b $ return message

1248

1249{-# INLINE traceMWhen #-}

1250traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()

1251traceMWhen b getMessage = when b $ do

1252 message <- getMessage

1253#ifdef DEBUG

1254 spiderTimeline <- askSpiderTimeline

1255 d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1256#else

1257 let d = 0

1258#endif

1259 liftIO $ putStrLn $ replicate d ' ' <> message

1260

1261whoCreatedIORef :: IORef a -> IO [String]

1262whoCreatedIORef (IORef a) = whoCreated $! a

1263

1264#ifdef DEBUG_CYCLES

1265groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1266groupByHead = \case

1267 [] -> []

1268 (x :| xs) : t -> case groupByHead t of

1269 [] -> [(x, xs :| [])]

1270 l@((y, yss) : t')

1271 | x == y -> (x, xs `NonEmpty.cons` yss) : t'

1272 | otherwise -> (x, xs :| []) : l

1273

1274listsToForest :: Eq a => [[a]] -> Forest a

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

1276#endif

1277

1278{-# INLINE propagateSubscriberHold #-}

1279propagateSubscriberHold :: R.Patch p => Hold x p -> p -> EventM x ()

1280propagateSubscriberHold h a = do

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

1282 invalidators <- liftIO $ readIORef $ holdInvalidators h

1283 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1284 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1285 case {-# SCC "apply" #-} R.apply a v of

1286 Nothing -> return ()

1287 Just v' -> do

1288 {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1289 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

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

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

1292

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

1294

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

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

1297

1298askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1299askInvalidator = do

1300 (!m, _) <- BehaviorM ask

1301 case m of

1302 Nothing -> return Nothing

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

1304

1305askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1306askParentsRef = do

1307 (!m, _) <- BehaviorM ask

1308 case m of

1309 Nothing -> return Nothing

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

1311

1312askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1313askBehaviorHoldInits = do

1314 (_, !his) <- BehaviorM ask

1315 return his

1316

1317{-# INLINE getDynHold #-}

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

1319getDynHold d = do

1320 mh <- liftIO $ readIORef $ unDyn d

1321 case mh of

1322 Right h -> return h

1323 Left (readV0, v') -> do

1324 holdInits <- getDeferralQueue

1325 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1326 h <- hold v0 v'

1327 liftIO $ writeIORef (unDyn d) $ Right h

1328 return h

1329

1330-- Always refers to 0

1331{-# NOINLINE zeroRef #-}

1332zeroRef :: IORef Height

1333zeroRef = unsafePerformIO $ newIORef zeroHeight

1334

1335type CanSubscribe x m =

1336 ( HasSpiderTimeline x m

1337 , HasCurrentHeight x m

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

1339 , Defer SomeClear m -- Wiping out event firings

1340 , Defer (SomeAssignment x) m -- Updating state

1341 , Defer (SomeResetCoincidence x) m

1342 , m ~ EventM x

1343 )

1344

1345getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1346getRootSubscribed k r sub = do

1347 mSubscribed <- readIORef $ rootSubscribed r

1348 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1349 case DMap.lookup k mSubscribed of

1350 Just subscribed -> {-# SCC "hitRoot" #-} do

1351 sln <- subscribeRootSubscribed subscribed sub

1352 occ <- getOcc

1353 return (sln, subscribed, occ)

1354 Nothing -> {-# SCC "missRoot" #-} do

1355 weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"

1356 let !cached = rootSubscribed r

1357 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1358 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1359 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1360 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1361 writeIORef uninitRef $! uninit

1362 let subscribed = RootSubscribed

1363 { rootSubscribedKey = k

1364 , rootSubscribedCachedSubscribed = cached

1365 , rootSubscribedOccurrence = getOcc

1366 , rootSubscribedSubscribers = subs

1367 , rootSubscribedUninit = uninit

1368 , rootSubscribedWeakSelf = weakSelf

1369#ifdef DEBUG_NODEIDS

1370 , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

1371#endif

1372 }

1373 writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "RootSubscribed"

1374 modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it

1375 occ <- getOcc

1376 return (sln, subscribed, occ)

1377

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

1379cleanupRootSubscribed :: RootSubscribed x a -> IO ()

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

1381 rootSubscribedUninit self

1382 modifyIORef' cached $ DMap.delete k

1383

1384{-# INLINE subscribeRootSubscribed #-}

1385subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

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

1387

1388{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) #-}

1389getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)

1390getFanSubscribed k f sub = do

1391 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1392 case mSubscribed of

1393 Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do

1394 sln <- subscribeFanSubscribed k subscribed sub

1395 occ <- readIORef $ fanSubscribedOccurrence subscribed

1396 return (sln, subscribed, coerce $ DMap.lookup k =<< occ)

1397 Nothing -> {-# SCC "missFan" #-} do

1398 subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"

1399 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1400 s <- liftIO $ newSubscriberFan subscribedUnsafe

1401 (subscription, parentOcc) <- subscribeAndRead (fanParent f) s

1402 weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"

1403 (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed

1404 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

1405 occRef <- liftIO $ newIORef parentOcc

1406 when (isJust parentOcc) $ scheduleClear occRef

1407 let subscribed = FanSubscribed

1408 { fanSubscribedCachedSubscribed = fanSubscribed f

1409 , fanSubscribedOccurrence = occRef

1410 , fanSubscribedParent = subscription

1411 , fanSubscribedSubscribers = subscribersRef

1412#ifdef DEBUG_NODEIDS

1413 , fanSubscribedNodeId = unsafeNodeId f

1414#endif

1415 }

1416 let !self = (k, subscribed)

1417 liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf

1418 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"

1419 liftIO $ writeIORef subscribedRef $! subscribed

1420 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1421 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

1422

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

1424cleanupFanSubscribed (k, subscribed) = do

1425 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1426 let reducedSubscribers = DMap.delete k subscribers

1427 if DMap.null reducedSubscribers

1428 then do

1429 unsubscribe $ fanSubscribedParent subscribed

1430 -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers

1431 writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing

1432 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1433

1434{-# INLINE subscribeFanSubscribed #-}

1435subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket

1436subscribeFanSubscribed k subscribed sub = do

1437 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1438 case DMap.lookup k subscribers of

1439 Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do

1440 let !self = (k, subscribed)

1441 weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"

1442 (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed

1443 writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeFanSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers

1444 return sln

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

1446

1447{-# SPECIALIZE getSwitchSubscribed :: Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a) #-}

1448getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x m, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)

1449getSwitchSubscribed s sub = do

1450 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1451 case mSubscribed of

1452 Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do

1453 sln <- subscribeSwitchSubscribed subscribed sub

1454 occ <- readIORef $ switchSubscribedOccurrence subscribed

1455 return (sln, subscribed, occ)

1456 Nothing -> {-# SCC "missSwitch" #-} do

1457 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"

1458 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1459 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe

1460 mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe

1461 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"

1462 wiRef <- liftIO $ newIORef wi

1463 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior

1464 holdInits <- getDeferralQueue

1465 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits

1466 (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub

1467 heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd

1468 subscriptionRef <- liftIO $ newIORef subscription

1469 occRef <- liftIO $ newIORef parentOcc

1470 when (isJust parentOcc) $ scheduleClear occRef

1471 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1472 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1473 let !subscribed = SwitchSubscribed

1474 { switchSubscribedCachedSubscribed = switchSubscribed s

1475 , switchSubscribedOccurrence = occRef

1476 , switchSubscribedHeight = heightRef

1477 , switchSubscribedSubscribers = subs

1478 , switchSubscribedOwnInvalidator = i

1479 , switchSubscribedOwnWeakInvalidator = wiRef

1480 , switchSubscribedBehaviorParents = parentsRef

1481 , switchSubscribedParent = switchParent s

1482 , switchSubscribedCurrentParent = subscriptionRef

1483 , switchSubscribedWeakSelf = weakSelf

1484#ifdef DEBUG_NODEIDS

1485 , switchSubscribedNodeId = unsafeNodeId s

1486#endif

1487 }

1488 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

1489 liftIO $ writeIORef subscribedRef $! subscribed

1490 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed

1491 return (slnForSub, subscribed, parentOcc)

1492

1493cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()

1494cleanupSwitchSubscribed subscribed = do

1495 unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)

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

1497 writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing

1498

1499{-# INLINE subscribeSwitchSubscribed #-}

1500subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket

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

1502

1503{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a) #-}

1504getCoincidenceSubscribed :: 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, HasSpiderTimeline x m, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)

1505getCoincidenceSubscribed c sub = do

1506 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1507 case mSubscribed of

1508 Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do

1509 sln <- subscribeCoincidenceSubscribed subscribed sub

1510 occ <- readIORef $ coincidenceSubscribedOccurrence subscribed

1511 return (sln, subscribed, occ)

1512 Nothing -> {-# SCC "missCoincidence" #-} do

1513 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"

1514 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1515 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe

1516 (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter

1517 outerHeight <- liftIO $ getEventSubscribedHeight outerSubd

1518 (occ, height, mInnerSubd) <- case outerOcc of

1519 Nothing -> return (Nothing, outerHeight, Nothing)

1520 Just o -> do

1521 (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe

1522 return (occ, height, Just innerSubd)

1523 occRef <- liftIO $ newIORef occ

1524 when (isJust occ) $ scheduleClear occRef

1525 heightRef <- liftIO $ newIORef height

1526 innerSubdRef <- liftIO $ newIORef mInnerSubd

1527 scheduleClear innerSubdRef

1528 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

1529 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1530 let subscribed = CoincidenceSubscribed

1531 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1532 , coincidenceSubscribedOccurrence = occRef

1533 , coincidenceSubscribedHeight = heightRef

1534 , coincidenceSubscribedSubscribers = subs

1535 , coincidenceSubscribedOuter = subOuter

1536 , coincidenceSubscribedOuterParent = outerSubscription

1537 , coincidenceSubscribedInnerParent = innerSubdRef

1538 , coincidenceSubscribedWeakSelf = weakSelf

1539#ifdef DEBUG_NODEIDS

1540 , coincidenceSubscribedNodeId = unsafeNodeId c

1541#endif

1542 }

1543 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

1544 liftIO $ writeIORef subscribedRef $! subscribed

1545 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1546 return (slnForSub, subscribed, occ)

1547

1548cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()

1549cleanupCoincidenceSubscribed subscribed = do

1550 unsubscribe $ coincidenceSubscribedOuterParent subscribed

1551 writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing

1552

1553{-# INLINE subscribeCoincidenceSubscribed #-}

1554subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

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

1556

1557{-# INLINE merge #-}

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

1559merge d = cacheEvent $ Event $ \sub -> do

1560 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1561 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1562 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1563 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1564 parentsRef <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1565 let scheduleSelf height = scheduleMerge' height heightRef $ do

1566 m <- liftIO $ readIORef accumRef

1567 liftIO $ writeIORef accumRef $! DMap.empty

1568 --TODO: Assert that m is not empty

1569 subscriberPropagate sub m

1570 invalidateMyHeight = do

1571 oldHeight <- readIORef heightRef

1572 when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1573 writeIORef heightRef $! invalidHeight

1574 subscriberInvalidateHeight sub oldHeight

1575 revalidateMyHeight = do

1576 currentHeight <- readIORef heightRef

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

1578 heights <- readIORef heightBagRef

1579 parents <- readIORef parentsRef

1580 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1581 case heightBagSize heights `compare` DMap.size parents of

1582 LT -> return ()

1583 EQ -> do

1584 let height = succHeight $ heightBagMax heights

1585 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1586 writeIORef heightRef $! height

1587 subscriberRecalculateHeight sub height

1588 GT -> error $ "revalidateMergeHeight: more heights than parents for Merge"

1589 subscriber :: forall a. k a -> Subscriber x a

1590 subscriber k = Subscriber

1591 { subscriberPropagate = \a -> do

1592 oldM <- liftIO $ readIORef accumRef

1593 let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1594 tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1595 liftIO $ writeIORef accumRef $! newM

1596 when (DMap.null oldM) $ do -- Only schedule the firing once

1597 height <- liftIO $ readIORef heightRef

1598 --TODO: assertions about height

1599 currentHeight <- getCurrentHeight

1600 when (height <= currentHeight) $ do

1601 if height /= invalidHeight

1602 then do

1603 myStack <- liftIO $ whoCreatedIORef undefined --TODO

1604 error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1605 else liftIO $ do

1606#ifdef DEBUG_CYCLES

1607 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1608 stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

1609 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1610#else

1611 let cycleInfo = ""

1612#endif

1613 error $ "Causality loop found" <> cycleInfo

1614 scheduleSelf height

1615 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

1616 modifyIORef' heightBagRef $ heightBagRemove old

1617 invalidateMyHeight

1618 , subscriberRecalculateHeight = \new -> do

1619 modifyIORef' heightBagRef $ heightBagAdd new

1620 revalidateMyHeight

1621 }

1622 subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent x))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1623 let s = subscriber k

1624 (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1625 height <- liftIO $ getEventSubscribedHeight parentSubd

1626 return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)

1627 let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1628 heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1629 myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1630 myHeight = if invalidHeight `elem` heights

1631 then invalidHeight

1632 else succHeight $ heightBagMax myHeightBag

1633 currentHeight <- getCurrentHeight

1634 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1635 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1636 else (Nothing, dm)

1637 unless (DMap.null accum) $ do

1638 scheduleSelf myHeight

1639 occRef <- liftIO $ newIORef occ

1640 when (isJust occ) $ scheduleClear occRef

1641 liftIO $ writeIORef accumRef $! accum

1642 liftIO $ writeIORef heightRef $! myHeight

1643 liftIO $ writeIORef heightBagRef $! myHeightBag

1644 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1645 liftIO $ writeIORef parentsRef $! DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1646 let updateMe (R.PatchDMap p) = do

1647 oldParents <- liftIO $ readIORef parentsRef

1648 let f (subscriptionsToKill, ps) (k :=> R.ComposeMaybe me) = do

1649 (mOldSubd, newPs) <- case me of

1650 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1651 Just e -> do

1652 let s = subscriber k

1653 subscription@(EventSubscription _ subd) <- subscribe e s

1654 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1655 let newParent = MergeSubscribedParent subscription

1656 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1657 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1658 forM_ mOldSubd $ \oldSubd -> do

1659 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1660 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1661 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1662 (subscriptionsToKill, newParents) <- foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be

1663 liftIO $ writeIORef parentsRef $! newParents

1664 return subscriptionsToKill

1665 defer $ SomeMergeInit $ do

1666 let s = Subscriber

1667 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1668 tracePropagate $ "SubscriberMerge/Change"

1669 defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

1670 , subscriberInvalidateHeight = \_ -> return ()

1671 , subscriberRecalculateHeight = \_ -> return ()

1672 }

1673 (EventSubscription _ changeSubd, change) <- subscribeAndRead (dynamicUpdated d) s

1674 forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

1675 liftIO $ writeIORef changeSubdRef (s, changeSubd)

1676 let unsubscribeAll = do

1677 parents <- readIORef parentsRef

1678 forM_ (DMap.toList parents) $ \(_ :=> MergeSubscribedParent s) -> unsubscribe s

1679 return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

1680 , occ

1681 )

1682

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

1684

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

1686fan e =

1687 let f = Fan

1688 { fanParent = e

1689 , fanSubscribed = unsafeNewIORef e Nothing

1690 }

1691 in EventSelector $ \k -> eventFan k f

1692

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

1694runHoldInits holdInitRef mergeInitRef = do

1695 holdInits <- liftIO $ readIORef holdInitRef

1696 mergeInits <- liftIO $ readIORef mergeInitRef

1697 unless (null holdInits && null mergeInits) $ do

1698 liftIO $ writeIORef holdInitRef []

1699 liftIO $ writeIORef mergeInitRef []

1700 mapM_ initHold holdInits

1701 mapM_ unSomeMergeInit mergeInits

1702 runHoldInits holdInitRef mergeInitRef

1703

1704initHold :: SomeHoldInit x -> EventM x ()

1705initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1706

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

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

1709runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do

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

1711 pendingCleanups <- atomicModifyIORef (_spiderTimeline_cleanups spiderTimeline) $ \x -> ([], x)

1712 {-# SCC "cleanups" #-} sequence_ pendingCleanups

1713 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

1714 holdInitRef <- newIORef []

1715 mergeUpdateRef <- newIORef []

1716 mergeInitRef <- newIORef []

1717 heightRef <- newIORef zeroHeight

1718 toClearRef <- newIORef []

1719 toClearEventCacheRef <- newIORef []

1720 toClearRootRef <- newIORef []

1721 coincidenceInfosRef <- newIORef []

1722 delayedRef <- liftIO $ newIORef IntMap.empty

1723 let env = EventEnv spiderTimeline toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearEventCacheRef toClearRootRef heightRef coincidenceInfosRef delayedRef

1724 let go = do

1725 result <- a

1726 runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

1727 return result

1728 result <- runEventM go env

1729 toClear <- readIORef toClearRef

1730 forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

1731 toClearEventCache <- readIORef toClearEventCacheRef

1732 forM_ toClearEventCache $ \(SomeClearEventCache c) -> {-# SCC "clearEventCache" #-} do

1733-- thawStruct c

1734 set eventCache_occurrence_slot c Nil

1735-- freezeStruct c

1736 toClearRoot <- readIORef toClearRootRef

1737 forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1738 toAssign <- readIORef toAssignRef

1739 toReconnectRef <- newIORef []

1740 coincidenceInfos <- readIORef coincidenceInfosRef

1741 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

1742 writeIORef vRef v

1743 when debugInvalidate $ putStrLn $ "Invalidating Hold"

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

1745 mergeUpdates <- readIORef mergeUpdateRef

1746 writeIORef mergeUpdateRef []

1747 when debugPropagate $ putStrLn "Updating merges"

1748 mergeSubscriptionsToKill <- flip runEventM env $ concat <$> mapM _someMergeUpdate_update mergeUpdates

1749 when debugPropagate $ putStrLn "Updating merges done"

1750 toReconnect <- readIORef toReconnectRef

1751 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

1752 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

1753 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

1754 when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

1755 finalize wi

1756 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

1757 wi' <- mkWeakPtrWithDebug i "wi'"

1758 writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'

1759 writeIORef (switchSubscribedBehaviorParents subscribed) []

1760 writeIORef holdInitRef [] --TODO: Should we reuse this?

1761 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef

1762 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant

1763 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1764 sub <- newSubscriberSwitch subscribed

1765 subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

1766 {-

1767 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1768 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

1769 EventRoot _ -> "EventRoot"

1770 EventNever -> "EventNever"

1771 _ -> "something else"

1772 -}

1773 writeIORef (switchSubscribedCurrentParent subscribed) $! subscription

1774 return oldSubscription

1775 liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill

1776 liftIO $ mapM_ unsubscribe switchSubscriptionsToKill

1777 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

1778 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed

1779 parentHeight <- getEventSubscribedHeight subd'

1780 myHeight <- readIORef $ switchSubscribedHeight subscribed

1781 when (parentHeight /= myHeight) $ do

1782 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

1783 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

1784 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different

1785 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

1786 unsubscribe subscription

1787 mapM_ invalidateCoincidenceHeight mcs

1788 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs

1789 mapM_ _someMergeUpdate_recalculateHeight mergeUpdates

1790 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do

1791 height <- calculateSwitchHeight subscribed

1792 updateSwitchHeight height subscribed

1793 return result

1794

1795newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)

1796

1797{-# INLINE zeroHeight #-}

1798zeroHeight :: Height

1799zeroHeight = Height 0

1800

1801{-# INLINE invalidHeight #-}

1802invalidHeight :: Height

1803invalidHeight = Height (-1000)

1804

1805#ifdef DEBUG_CYCLES

1806-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents

1807{-# INLINE invalidHeightBeingTraversed #-}

1808invalidHeightBeingTraversed :: Height

1809invalidHeightBeingTraversed = Height (-1001)

1810#endif

1811

1812{-# INLINE succHeight #-}

1813succHeight :: Height -> Height

1814succHeight h@(Height a) =

1815 if h == invalidHeight

1816 then invalidHeight

1817 else Height $ succ a

1818

1819invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

1820invalidateCoincidenceHeight subscribed = do

1821 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1822 when (oldHeight /= invalidHeight) $ do

1823 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

1824 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1825

1826updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

1827updateSwitchHeight new subscribed = do

1828 oldHeight <- readIORef $ switchSubscribedHeight subscribed

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

1830 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1831 writeIORef (switchSubscribedHeight subscribed) $! new

1832 WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

1833

1834recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

1835recalculateCoincidenceHeight subscribed = do

1836 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

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

1838 height <- calculateCoincidenceHeight subscribed

1839 when (height /= invalidHeight) $ do

1840 writeIORef (coincidenceSubscribedHeight subscribed) $! height

1841 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

1842

1843calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

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

1845

1846calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height

1847calculateCoincidenceHeight subscribed = do

1848 outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

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

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

1851

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

1853

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

1855invalidate toReconnectRef wis = do

1856 forM_ wis $ \wi -> do

1857 mi <- deRefWeak wi

1858 case mi of

1859 Nothing -> do

1860 traceInvalidate "invalidate Dead"

1861 return () --TODO: Should we clean this up here?

1862 Just i -> do

1863 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict

1864 case i of

1865 InvalidatorPull p -> do

1866 traceInvalidate $ "invalidate: Pull" <> showNodeId p

1867 mVal <- readIORef $ pullValue p

1868 forM_ mVal $ \val -> do

1869 writeIORef (pullValue p) Nothing

1870 writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)

1871 InvalidatorSwitch subscribed -> do

1872 traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed

1873 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)

1874 return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them

1875

1876--------------------------------------------------------------------------------

1877-- Reflex integration

1878--------------------------------------------------------------------------------

1879

1880-- | The default, global Spider environment

1881type Spider = SpiderTimeline Global

1882

1883-- | Designates the default, global Spider timeline

1884data Global

1885

1886{-# NOINLINE globalSpiderTimeline #-}

1887globalSpiderTimeline :: SpiderTimeline Global

1888globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline

1889

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

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

1892data SpiderTimeline x = SpiderTimeline

1893 { _spiderTimeline_toUnsubscribe :: !(IORef [EventSubscription x])

1894 , _spiderTimeline_lock :: !(MVar ())

1895 , _spiderTimeline_cleanups :: !(IORef [IO ()])

1896#ifdef DEBUG

1897 , _spiderTimeline_depth :: !(IORef Int)

1898#endif

1899 }

1900type role SpiderTimeline nominal

1901

1902instance GEq SpiderTimeline where

1903 a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

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

1905 else Nothing

1906

1907unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)

1908unsafeNewSpiderTimeline = do

1909 toUnsubscribe <- newIORef []

1910 lock <- newMVar ()

1911 cleanups <- newIORef []

1912#ifdef DEBUG

1913 depthRef <- newIORef 0

1914#endif

1915 return $ SpiderTimeline

1916 { _spiderTimeline_toUnsubscribe = toUnsubscribe

1917 , _spiderTimeline_lock = lock

1918 , _spiderTimeline_cleanups = cleanups

1919#ifdef DEBUG

1920 , _spiderTimeline_depth = depthRef

1921#endif

1922 }

1923

1924-- | Create a new SpiderTimeline

1925newSpiderTimeline :: IO (Some SpiderTimeline)

1926newSpiderTimeline = withSpiderTimeline (pure . Some.This)

1927

1928-- | Pass a new timeline to the given function.

1929withSpiderTimeline :: (forall x. SpiderTimeline x -> IO r) -> IO r

1930withSpiderTimeline k = unsafeNewSpiderTimeline >>= k

1931

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

1933

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

1935

1936instance Functor (R.Dynamic (SpiderTimeline x)) where

1937 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

1938

1939instance Applicative (R.Dynamic (SpiderTimeline x)) where

1940 pure = SpiderDynamic . dynamicConst

1941 SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b

1942 _ *> b = b

1943 a <* _ = a

1944

1945instance Monad (R.Dynamic (SpiderTimeline x)) where

1946 {-# INLINE return #-}

1947 return = pure

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

1949 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

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

1951 _ >> y = y

1952 {-# INLINE fail #-}

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

1954

1955instance R.Reflex (SpiderTimeline x) where

1956 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

1957 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

1958 newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

1959 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

1960 type PullM (SpiderTimeline x) = SpiderPullM x

1961 type PushM (SpiderTimeline x) = SpiderPushM x

1962 {-# INLINABLE never #-}

1963 never = SpiderEvent eventNever

1964 {-# INLINABLE constant #-}

1965 constant = SpiderBehavior . behaviorConst

1966 {-# INLINABLE push #-}

1967 push f = SpiderEvent . push (coerce f) . unSpiderEvent

1968 {-# INLINABLE pull #-}

1969 pull = SpiderBehavior . pull . coerce

1970 {-# INLINABLE merge #-}

1971 merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

1972 {-# INLINABLE fan #-}

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

1974 {-# INLINABLE switch #-}

1975 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

1976 {-# INLINABLE coincidence #-}

1977 coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent

1978 {-# INLINABLE current #-}

1979 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

1980 {-# INLINABLE updated #-}

1981 updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic

1982 {-# INLINABLE unsafeBuildDynamic #-}

1983 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'

1984 {-# INLINABLE unsafeBuildIncremental #-}

1985 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

1986 {-# INLINABLE mergeIncremental #-}

1987 mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (R.PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (R.PatchDMap k (Event x))) . unSpiderIncremental

1988 {-# INLINABLE currentIncremental #-}

1989 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

1990 {-# INLINABLE updatedIncremental #-}

1991 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

1992 {-# INLINABLE incrementalToDynamic #-}

1993 incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do

1994 c <- readBehaviorUntracked $ dynamicCurrent i

1995 return $ Identity <$> R.apply p c --TODO: Avoid the redundant 'apply'

1996 eventCoercion Coercion = Coercion

1997 behaviorCoercion Coercion = Coercion

1998 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

1999

2000instance R.MonadSample (SpiderTimeline x) (EventM x) where

2001 {-# INLINABLE sample #-}

2002 sample (SpiderBehavior b) = readBehaviorUntracked b

2003

2004instance R.MonadHold (SpiderTimeline x) (EventM x) where

2005 {-# INLINABLE hold #-}

2006 hold = holdSpiderEventM

2007 {-# INLINABLE holdDyn #-}

2008 holdDyn = holdDynSpiderEventM

2009 {-# INLINABLE holdIncremental #-}

2010 holdIncremental = holdIncrementalSpiderEventM

2011

2012holdSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)

2013holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2014

2015holdDynSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

2016holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2017

2018holdIncrementalSpiderEventM :: R.Patch p => R.PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)

2019holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

2020

2021instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where

2022 {-# INLINABLE hold #-}

2023 hold v0 e = R.runHostFrame $ R.hold v0 e

2024 {-# INLINABLE holdDyn #-}

2025 holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e

2026 {-# INLINABLE holdIncremental #-}

2027 holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e

2028

2029instance R.MonadSample (SpiderTimeline x) (SpiderHost x) where

2030 {-# INLINABLE sample #-}

2031 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

2032

2033instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2034 {-# INLINABLE sample #-}

2035 sample = coerce . readBehaviorTracked . unSpiderBehavior

2036

2037instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

2038 {-# INLINABLE sample #-}

2039 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2040

2041instance R.MonadHold (SpiderTimeline x) (SpiderPushM x) where

2042 {-# INLINABLE hold #-}

2043 hold v0 e = R.current <$> R.holdDyn v0 e

2044 {-# INLINABLE holdDyn #-}

2045 holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce e

2046 {-# INLINABLE holdIncremental #-}

2047 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> hold v0 e

2048

2049data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2050

2051data SpiderEventHandle x a = SpiderEventHandle

2052 { spiderEventHandleSubscription :: EventSubscription x

2053 , spiderEventHandleValue :: IORef (Maybe a)

2054 }

2055

2056instance R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2057 {-# INLINABLE subscribeEvent #-}

2058 subscribeEvent e = SpiderHostFrame $ do

2059 --TODO: Unsubscribe eventually (manually and/or with weak ref)

2060 val <- liftIO $ newIORef Nothing

2061 subscription <- subscribe (unSpiderEvent e) $ Subscriber

2062 { subscriberPropagate = \a -> do

2063 liftIO $ writeIORef val $ Just a

2064 scheduleClear val

2065 , subscriberInvalidateHeight = \_ -> return ()

2066 , subscriberRecalculateHeight = \_ -> return ()

2067 }

2068 return $ SpiderEventHandle

2069 { spiderEventHandleSubscription = subscription

2070 , spiderEventHandleValue = val

2071 }

2072

2073instance R.ReflexHost (SpiderTimeline x) where

2074 type EventTrigger (SpiderTimeline x) = RootTrigger x

2075 type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2076 type HostFrame (SpiderTimeline x) = SpiderHostFrame x

2077

2078instance R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where

2079 {-# NOINLINE readEvent #-}

2080 readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2081 result <- readIORef $ spiderEventHandleValue h

2082 touch h

2083 return result

2084

2085instance MonadRef (EventM x) where

2086 type Ref (EventM x) = Ref IO

2087 {-# INLINABLE newRef #-}

2088 {-# INLINABLE readRef #-}

2089 {-# INLINABLE writeRef #-}

2090 newRef = liftIO . newRef

2091 readRef = liftIO . readRef

2092 writeRef r a = liftIO $ writeRef r a

2093

2094instance MonadAtomicRef (EventM x) where

2095 {-# INLINABLE atomicModifyRef #-}

2096 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2097

2098-- | The monad for actions that manipulate a Spider timeline identified by @x@

2099newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimeline x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2100

2101instance Monad (SpiderHost x) where

2102 {-# INLINABLE (>>=) #-}

2103 SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f

2104 {-# INLINABLE (>>) #-}

2105 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2106 {-# INLINABLE return #-}

2107 return x = SpiderHost $ return x

2108 {-# INLINABLE fail #-}

2109 fail s = SpiderHost $ fail s

2110

2111-- | Run an action affecting the global Spider timeline; this will be guarded by

2112-- a mutex for that timeline

2113runSpiderHost :: SpiderHost Global a -> IO a

2114runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimeline

2115

2116-- | Run an action affecting a given Spider timeline; this will be guarded by a

2117-- mutex for that timeline

2118runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimeline x -> IO a

2119runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2120

2121newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2122

2123instance Monad (SpiderHostFrame x) where

2124 {-# INLINABLE (>>=) #-}

2125 SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f

2126 {-# INLINABLE (>>) #-}

2127 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2128 {-# INLINABLE return #-}

2129 return x = SpiderHostFrame $ return x

2130 {-# INLINABLE fail #-}

2131 fail s = SpiderHostFrame $ fail s

2132

2133instance R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

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

2135

2136instance R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

2137 {-# INLINABLE hold #-}

2138 hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2139 {-# INLINABLE holdDyn #-}

2140 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2141 {-# INLINABLE holdIncremental #-}

2142 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

2143

2144newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2145newEventWithTriggerIO f = do

2146 es <- newFanEventWithTriggerIO $ \Refl -> f