3a0f375 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Make Events just a monad action

3a0f375Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+57−49

compare with develop

unifiedsplit

@@ -187,38 +187,45 @@ unsafeNodeId a = unsafePerformIO $ do

187-- Event

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

189

190−data Event a

191− = forall k. GCompare k => EventRoot !(k a) !(Root k)

192− | EventNever

193− | forall b. EventPush !(Push b a)

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

195− | forall k. GCompare k => EventFan !(k a) !(Fan k)

196− | EventSwitch !(Switch a)

197− | EventCoincidence !(Coincidence a)

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

199− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)

200− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)

201− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)

202−

203−{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}

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

191+

204−subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)

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

205−subscribe e sub = case e of

193+wrap tag getSpecificSubscribed sub = do

194+ (sln, subd) <- getSpecificSubscribed sub

195+ return $ EventSubscription (Just sln) $ tag subd

196+

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

206− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r

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

199+

200+eventNever :: Event a

207− EventNever -> return $ EventSubscription Nothing EventSubscribedNever

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

202+

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

208− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p

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

209− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f

205+

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

210− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m

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

208+

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

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

211+

212+eventSwitch :: Switch a -> Event a

211− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s

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

214+

215+eventCoincidence :: Coincidence a -> Event a

212− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c

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

213− EventHold h -> subscribeHoldEvent h sub

217+

214− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub

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

215− EventHoldIdentity h -> subscribeHoldEvent h sub

219+eventHold !h = Event $ subscribeHoldEvent h

220+

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

216− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub

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

217− where

223+

218− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)

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

219− wrap tag getSpecificSubscribed = do

225+eventHoldIdentity !h = Event $ subscribeHoldEvent h

220− (sln, subd) <- getSpecificSubscribed sub

226+

221− return $ EventSubscription (Just sln) $ tag subd

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

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

222

229

223{-# INLINE subscribeCoincidenceInner #-}

230{-# INLINE subscribeCoincidenceInner #-}

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

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

@@ -493,7 +500,7 @@ hold v0 e = do

493 return h

500 return h

494

501

495{-# INLINE getHoldEventSubscription #-}

502{-# INLINE getHoldEventSubscription #-}

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

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

497getHoldEventSubscription h = do

504getHoldEventSubscription h = do

498 ep <- liftIO $ readIORef $ holdParent h

505 ep <- liftIO $ readIORef $ holdParent h

499 case ep of

506 case ep of

@@ -835,11 +842,11 @@ current = \case

835{-# INLINE updated #-}

842{-# INLINE updated #-}

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

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

837updated = \case

844updated = \case

838− DynamicHold h -> EventHold h

845+ DynamicHold h -> eventHold h

839− DynamicHoldIdentity h -> EventHoldIdentity h

846+ DynamicHoldIdentity h -> eventHoldIdentity h

840− DynamicConst _ -> EventNever

847+ DynamicConst _ -> eventNever

841− DynamicDyn d -> EventDyn d

848+ DynamicDyn d -> eventDyn d

842− DynamicDynIdentity d -> EventDynIdentity d

849+ DynamicDynIdentity d -> eventDynIdentity d

843

850

844newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b

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

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

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

@@ -857,7 +864,7 @@ instance R.FunctorMaybe Event where

857 fmapMaybe f = push $ return . f

864 fmapMaybe f = push $ return . f

858

865

859instance Align Event where

866instance Align Event where

860− nil = EventNever

867+ nil = eventNever

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

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

862

869

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

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

@@ -925,7 +932,7 @@ instance Functor Behavior where

925

932

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

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

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

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

928−push f e = EventPush $ Push

935+push f e = eventPush $ Push

929 { pushCompute = f

936 { pushCompute = f

930 , pushParent = e

937 , pushParent = e

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

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

@@ -944,13 +951,13 @@ pull a = BehaviorPull $ Pull

944

951

945{-# NOINLINE switch #-}

952{-# NOINLINE switch #-}

946switch :: Behavior (Event a) -> Event a

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

947−switch a = EventSwitch $ Switch

954+switch a = eventSwitch $ Switch

948 { switchParent = a

955 { switchParent = a

949 , switchSubscribed = unsafeNewIORef a Nothing

956 , switchSubscribed = unsafeNewIORef a Nothing

950 }

957 }

951

958

952coincidence :: Event (Event a) -> Event a

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

953−coincidence a = EventCoincidence $ Coincidence

960+coincidence a = eventCoincidence $ Coincidence

954 { coincidenceParent = a

961 { coincidenceParent = a

955 , coincidenceSubscribed = unsafeNewIORef a Nothing

962 , coincidenceSubscribed = unsafeNewIORef a Nothing

956 }

963 }

@@ -1327,6 +1334,7 @@ type CanSubscribe x m =

1327 , Defer SomeClear m -- Wiping out event firings

1334 , Defer SomeClear m -- Wiping out event firings

1328 , Defer SomeAssignment m -- Updating state

1335 , Defer SomeAssignment m -- Updating state

1329 , Defer SomeResetCoincidence m

1336 , Defer SomeResetCoincidence m

1337+ , m ~ EventM x

1330 )

1338 )

1331

1339

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

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

@@ -1487,7 +1495,7 @@ subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) ->

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

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

1488

1496

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

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

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

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

1491getFanSubscribed k f sub = do

1499getFanSubscribed k f sub = do

1492 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1500 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1493 case mSubscribed of

1501 case mSubscribed of

@@ -1542,7 +1550,7 @@ subscribeFanSubscribed k subscribed sub = do

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

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

1543

1551

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

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

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

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

1546getSwitchSubscribed s sub = do

1554getSwitchSubscribed s sub = do

1547 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1555 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1548 case mSubscribed of

1556 case mSubscribed of

@@ -1598,7 +1606,7 @@ subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (Subscribe

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

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

1599

1607

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

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

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

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

1602getCoincidenceSubscribed c sub = do

1610getCoincidenceSubscribed c sub = do

1603 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1611 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1604 case mSubscribed of

1612 case mSubscribed of

@@ -1653,7 +1661,7 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS

1653

1661

1654{-# INLINE merge #-}

1662{-# INLINE merge #-}

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

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

1656−merge m = EventMerge $ Merge

1664+merge m = eventMerge $ Merge

1657 { mergeParents = m

1665 { mergeParents = m

1658 , mergeSubscribed = unsafeNewIORef m Nothing

1666 , mergeSubscribed = unsafeNewIORef m Nothing

1659 }

1667 }

@@ -1666,7 +1674,7 @@ fan e =

1666 { fanParent = e

1674 { fanParent = e

1667 , fanSubscribed = unsafeNewIORef e Nothing

1675 , fanSubscribed = unsafeNewIORef e Nothing

1668 }

1676 }

1669− in EventSelector $ \k -> EventFan k f

1677+ in EventSelector $ \k -> eventFan k f

1670

1678

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

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

1672runHoldInits holdInitRef mergeInitRef = do

1680runHoldInits holdInitRef mergeInitRef = do

@@ -2043,7 +2051,7 @@ instance R.Reflex (SpiderEnv x) where

2043 type PullM (SpiderEnv x) = SpiderPullM x

2051 type PullM (SpiderEnv x) = SpiderPullM x

2044 type PushM (SpiderEnv x) = SpiderPushM x

2052 type PushM (SpiderEnv x) = SpiderPushM x

2045 {-# INLINABLE never #-}

2053 {-# INLINABLE never #-}

2046− never = SpiderEvent EventNever

2054+ never = SpiderEvent eventNever

2047 {-# INLINABLE constant #-}

2055 {-# INLINABLE constant #-}

2048 constant = SpiderBehavior . BehaviorConst

2056 constant = SpiderBehavior . BehaviorConst

2049 {-# INLINABLE push #-}

2057 {-# INLINABLE push #-}

@@ -2220,7 +2228,7 @@ newFanEventWithTriggerIO f = do

2220 , rootSubscribed = subscribedRef

2228 , rootSubscribed = subscribedRef

2221 , rootInit = f

2229 , rootInit = f

2222 }

2230 }

2223− return $ EventSelector $ \k -> EventRoot k r

2231+ return $ EventSelector $ \k -> eventRoot k r

2224

2232

2225instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where

2233instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where

2226 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

2234 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO