f2205a1 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Eliminate sum type for EventSubscribed

f2205a1Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+98−105

compare with develop

unifiedsplit

@@ -194,25 +194,25 @@ wrap tag getSpecificSubscribed sub = do

194 return $ EventSubscription (Just sln) $ tag subd

195

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

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

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

198

199eventNever :: Event x a

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

200+eventNever = Event $ \_ -> return $ EventSubscription Nothing eventSubscribedNever

201

202eventPush :: Push x b a -> Event x a

203−eventPush !p = Event $ wrap EventSubscribedPush $ getPushSubscribed p

203+eventPush !p = Event $ wrap eventSubscribedPush $ getPushSubscribed p

204

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

206−eventMerge !m = Event $ wrap EventSubscribedMerge $ getMergeSubscribed m

206+eventMerge !m = Event $ wrap eventSubscribedMerge $ getMergeSubscribed m

207

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

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

209+eventFan !k !f = Event $ wrap (eventSubscribedFan k) $ getFanSubscribed k f

210

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

212−eventSwitch !s = Event $ wrap EventSubscribedSwitch $ getSwitchSubscribed s

212+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

213

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

215−eventCoincidence !c = Event $ wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c

215+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

216

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

218eventHold !h = Event $ subscribeHoldEvent h

@@ -302,7 +302,7 @@ newSubscriberMerge k subscribed = return $ Subscriber

302 if height /= invalidHeight

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

304 else liftIO $ do

305− nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed

305+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

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

307 error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)

308 scheduleMerge height subscribed

@@ -438,103 +438,104 @@ propagate a subscribers = withIncreasedDepth $ do

438-- EventSubscribed

439--------------------------------------------------------------------------------

440

441−data EventSubscribed x a

441+data EventSubscribed x a = EventSubscribed

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

442+ { eventSubscribedSubscribe :: !(Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a))))

443− | EventSubscribedNever

443+ , eventSubscribedRead :: !(IO (Maybe a))

444− | forall b. EventSubscribedPush !(PushSubscribed x b a)

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

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

445+ , eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

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

446+ , eventSubscribedHasOwnHeightRef :: !Bool

447− | EventSubscribedSwitch !(SwitchSubscribed x a)

447+ , eventSubscribedWhoCreated :: !(IO [String])

448− | EventSubscribedCoincidence !(CoincidenceSubscribed x a)

448+ }

449

450readEventSubscribed :: EventSubscribed x a -> IO (Maybe a)

451−readEventSubscribed = \case

451+readEventSubscribed = eventSubscribedRead

452− EventSubscribedRoot rs -> readRootSubscribed rs

452+

453− EventSubscribedNever -> return Nothing

454− EventSubscribedPush ps -> readPushSubscribed ps

455− EventSubscribedMerge ms -> readMergeSubscribed ms

456− EventSubscribedFan k fs -> readFanSubscribed k fs

457− EventSubscribedSwitch ss -> readSwitchSubscribed ss

458− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs

459−

460−{-# INLINE subscribeEventSubscribed #-}

461subscribeEventSubscribed :: EventSubscribed x a -> Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a)))

453subscribeEventSubscribed :: EventSubscribed x a -> Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a)))

462−subscribeEventSubscribed es sub = case es of

454+subscribeEventSubscribed = eventSubscribedSubscribe

463− EventSubscribedRoot r -> do

455+

464− traceSubscribe $ "subscribeEventSubscribed Root"

456+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x a

457+eventSubscribedRoot !r = EventSubscribed

465− Just <$> subscribeRootSubscribed r sub

458+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeRootSubscribed r sub

466− EventSubscribedNever -> do

459+ , eventSubscribedRead = readRootSubscribed r

467− traceSubscribe $ "subscribeEventSubscribed Never"

460+ , eventSubscribedGetParents = return []

461+ , eventSubscribedHeightRef = zeroRef

462+ , eventSubscribedHasOwnHeightRef = False

463+ , eventSubscribedWhoCreated = return ["root"]

464+ }

465+

466+eventSubscribedNever :: EventSubscribed x a

467+eventSubscribedNever = EventSubscribed

468− return Nothing

468+ { eventSubscribedSubscribe = \_ -> return Nothing

469− EventSubscribedPush subscribed -> do

469+ , eventSubscribedRead = return Nothing

470− traceSubscribe $ "subscribeEventSubscribed Push"

470+ , eventSubscribedGetParents = return []

471+ , eventSubscribedHeightRef = zeroRef

472+ , eventSubscribedHasOwnHeightRef = False

473+ , eventSubscribedWhoCreated = return ["never"]

474+ }

475+

476+eventSubscribedPush :: PushSubscribed x b a -> EventSubscribed x a

477+eventSubscribedPush !subscribed = EventSubscribed

471− Just <$> subscribePushSubscribed subscribed sub

478+ { eventSubscribedSubscribe = \sub -> Just <$> subscribePushSubscribed subscribed sub

472− EventSubscribedFan k subscribed -> do

479+ , eventSubscribedRead = readPushSubscribed subscribed

473− traceSubscribe $ "subscribeEventSubscribed Fan"

474− Just <$> subscribeFanSubscribed k subscribed sub

475− EventSubscribedMerge subscribed -> do

476− traceSubscribe $ "subscribeEventSubscribed Merge"

477− Just <$> subscribeMergeSubscribed subscribed sub

478− EventSubscribedSwitch subscribed -> do

479− traceSubscribe $ "subscribeEventSubscribed Switch"

480− Just <$> subscribeSwitchSubscribed subscribed sub

481− EventSubscribedCoincidence subscribed -> do

482− traceSubscribe $ "subscribeEventSubscribed Coincidence"

483− Just <$> subscribeCoincidenceSubscribed subscribed sub

484−

485−{-# INLINE eventSubscribedGetParents #-}

486−eventSubscribedGetParents :: EventSubscribed x a -> IO [Some (EventSubscribed x)]

487−eventSubscribedGetParents = \case

488− EventSubscribedRoot _ -> return []

489− EventSubscribedNever -> return []

490− EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]

480+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]

491− EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

481+ , eventSubscribedHeightRef = pushSubscribedHeight subscribed

492− EventSubscribedMerge subscribed -> do

482+ , eventSubscribedHasOwnHeightRef = False

483+ , eventSubscribedWhoCreated = whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed

484+ }

485+

486+eventSubscribedMerge :: a ~ DMap k Identity => MergeSubscribed x k -> EventSubscribed x a

487+eventSubscribedMerge !subscribed = EventSubscribed

488+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeMergeSubscribed subscribed sub

489+ , eventSubscribedRead = readMergeSubscribed subscribed

490+ , eventSubscribedGetParents = do

493− ps <- readIORef $ mergeSubscribedParents subscribed

491+ ps <- readIORef $ mergeSubscribedParents subscribed

494− return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v

492+ return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v

495− EventSubscribedSwitch subscribed -> do

493+ , eventSubscribedHeightRef = mergeSubscribedHeight subscribed

494+ , eventSubscribedHasOwnHeightRef = True

495+ , eventSubscribedWhoCreated = whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed

496+ }

497+

498+eventSubscribedFan :: GCompare k => k a -> FanSubscribed x k -> EventSubscribed x a

499+eventSubscribedFan !k !subscribed = EventSubscribed

500+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeFanSubscribed k subscribed sub

501+ , eventSubscribedRead = readFanSubscribed k subscribed

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

503+ , eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

504+ , eventSubscribedHasOwnHeightRef = False

505+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

506+ }

507+

508+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x a

509+eventSubscribedSwitch !subscribed = EventSubscribed

510+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeSwitchSubscribed subscribed sub

511+ , eventSubscribedRead = readSwitchSubscribed subscribed

512+ , eventSubscribedGetParents = do

496− s <- readIORef $ switchSubscribedCurrentParent subscribed

513+ s <- readIORef $ switchSubscribedCurrentParent subscribed

497− return [Some.This $ _eventSubscription_subscribed s]

514+ return [Some.This $ _eventSubscription_subscribed s]

498− EventSubscribedCoincidence subscribed -> do

515+ , eventSubscribedHeightRef = switchSubscribedHeight subscribed

516+ , eventSubscribedHasOwnHeightRef = True

517+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

518+ }

519+

520+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x a

521+eventSubscribedCoincidence !subscribed = EventSubscribed

522+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeCoincidenceSubscribed subscribed sub

523+ , eventSubscribedRead = readCoincidenceSubscribed subscribed

524+ , eventSubscribedGetParents = do

499− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

525+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

500− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

526+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

501− innerParents = maybeToList $ fmap Some.This innerSubscription

527+ innerParents = maybeToList $ fmap Some.This innerSubscription

502− return $ outerParent : innerParents

528+ return $ outerParent : innerParents

529+ , eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed

530+ , eventSubscribedHasOwnHeightRef = True

531+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

532+ }

503

533

504getEventSubscribedHeight :: EventSubscribed x a -> IO Height

534getEventSubscribedHeight :: EventSubscribed x a -> IO Height

505getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

535getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

506

536

507−{-# INLINE eventSubscribedHeightRef #-}

508−eventSubscribedHeightRef :: EventSubscribed x a -> IORef Height

509−eventSubscribedHeightRef = \case

510− EventSubscribedRoot _ -> zeroRef

511− EventSubscribedNever -> zeroRef

512− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed

513− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

514− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed

515− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed

516− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed

517−

518whoCreatedEventSubscribed :: EventSubscribed x a -> IO [String]

537whoCreatedEventSubscribed :: EventSubscribed x a -> IO [String]

519−whoCreatedEventSubscribed = \case

538+whoCreatedEventSubscribed = eventSubscribedWhoCreated

520− EventSubscribedRoot _ -> return ["root"]

521− EventSubscribedNever -> return ["never"]

522− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed

523− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

524− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed

525− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

526− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

527−

528−{-# INLINE eventSubscribedHasOwnHeightRef #-}

529−eventSubscribedHasOwnHeightRef :: EventSubscribed x a -> Bool

530−eventSubscribedHasOwnHeightRef = \case

531− EventSubscribedRoot _ -> False

532− EventSubscribedNever -> False

533− EventSubscribedPush _ -> False

534− EventSubscribedFan _ _ -> False

535− EventSubscribedMerge _ -> True

536− EventSubscribedSwitch _ -> True

537− EventSubscribedCoincidence _ -> True

538

539

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

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

540walkInvalidHeightParents s0 = do

541walkInvalidHeightParents s0 = do

@@ -1191,10 +1192,6 @@ type CanTrace x m = (HasSpiderEnv x m, MonadIO m)

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

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

1192tracePropagate = traceWhen debugPropagate

1193tracePropagate = traceWhen debugPropagate

1193

1194

1194−{-# INLINE traceSubscribe #-}

1195−traceSubscribe :: String -> IO ()

1196−traceSubscribe = when debugSubscribe . liftIO . putStrLn

1197−

1198{-# INLINE traceInvalidate #-}

1195{-# INLINE traceInvalidate #-}

1199traceInvalidate :: String -> IO ()

1196traceInvalidate :: String -> IO ()

1200traceInvalidate = when debugInvalidate . liftIO . putStrLn

1197traceInvalidate = when debugInvalidate . liftIO . putStrLn

@@ -1368,10 +1365,6 @@ readCoincidenceSubscribed subscribed = do

1368zeroRef :: IORef Height

1365zeroRef :: IORef Height

1369zeroRef = unsafePerformIO $ newIORef zeroHeight

1366zeroRef = unsafePerformIO $ newIORef zeroHeight

1370

1367

1371−{-# INLINE debugSubscribe #-}

1372−debugSubscribe :: Bool

1373−debugSubscribe = False

1374−

1375type CanSubscribe x m =

1368type CanSubscribe x m =

1376 ( HasSpiderEnv x m

1369 ( HasSpiderEnv x m

1377 , HasCurrentHeight x m

1370 , HasCurrentHeight x m