17ccde7 · reflex · git.iko.soy

git.iko.soy/reflex

Merge pull request #416 from parenthetical/now-event

Extend the Reflex class with `now :: PushM t (Event t ())`. (Issue #414)

commit17ccde728a81287e48c52654e7d3091f9a88200e authorRyan Trinkle <ryan@trinkle.org> dateThu 14 May 2020, 11:15 (6 years ago) parent2fb7cfd 502b508

11 files changed+74−3

compare with develop

unifiedsplit

ChangeLog.md+3 src/Reflex/Class.hs+13 src/Reflex/EventWriter/Base.hs+2 src/Reflex/PerformEvent/Base.hs+2 src/Reflex/PostBuild/Base.hs+2 src/Reflex/Profiled.hs+1 src/Reflex/Pure.hs+4 src/Reflex/Spider/Internal.hs+36−1 src/Reflex/TriggerEvent/Base.hs+2 test/Reflex/Plan/Pure.hs+1 test/Reflex/Test/Micro.hs+8−2

ChangeLog.md+3

@@ -1,5 +1,8 @@

11# Revision history for reflex

3+## Unreleased

4+* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.

36## 0.7.1.0

58* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.

src/Reflex/Class.hs+13

@@ -420,6 +420,13 @@ class MonadSample t m => MonadHold t m where

420420 -- | Create a new 'Event' that only occurs only once, on the first occurrence of

421421 -- the supplied 'Event'.

422422 headE :: Event t a -> m (Event t a)

423+ -- | An event which only occurs at the current moment in time, such that:

424+ --

425+ -- > coincidence (pushAlways (\a -> (a <$) <$> now) e) = e

426+ --

427+ now :: m (Event t ())

428+ default now :: (m ~ f m', MonadTrans f, MonadHold t m') => m (Event t ())

429+ now = lift now

423430

424431-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',

425432-- using the combining function to produce a patch.

@@ -565,6 +572,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

565572 holdIncremental a0 = lift . holdIncremental a0

566573 buildDynamic a0 = lift . buildDynamic a0

567574 headE = lift . headE

575+ now = lift now

568576

569577instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where

570578 sample = lift . sample

@@ -575,6 +583,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

575583 holdIncremental a0 = lift . holdIncremental a0

576584 buildDynamic a0 = lift . buildDynamic a0

577585 headE = lift . headE

586+ now = lift now

578587

579588instance MonadSample t m => MonadSample t (StateT s m) where

580589 sample = lift . sample

@@ -585,6 +594,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where

585594 holdIncremental a0 = lift . holdIncremental a0

586595 buildDynamic a0 = lift . buildDynamic a0

587596 headE = lift . headE

597+ now = lift now

588598

589599instance MonadSample t m => MonadSample t (ExceptT e m) where

590600 sample = lift . sample

@@ -595,6 +605,7 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where

595605 holdIncremental a0 = lift . holdIncremental a0

596606 buildDynamic a0 = lift . buildDynamic a0

597607 headE = lift . headE

608+ now = lift now

598609

599610instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where

600611 sample = lift . sample

@@ -605,6 +616,7 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where

605616 holdIncremental a0 = lift . holdIncremental a0

606617 buildDynamic a0 = lift . buildDynamic a0

607618 headE = lift . headE

619+ now = lift now

608620

609621instance MonadSample t m => MonadSample t (ContT r m) where

610622 sample = lift . sample

@@ -615,6 +627,7 @@ instance MonadHold t m => MonadHold t (ContT r m) where

615627 holdIncremental a0 = lift . holdIncremental a0

616628 buildDynamic a0 = lift . buildDynamic a0

617629 headE = lift . headE

630+ now = lift now

618631

619632--------------------------------------------------------------------------------

620633-- Convenience functions

src/Reflex/EventWriter/Base.hs+2

@@ -133,6 +133,8 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where

133133 buildDynamic a0 = lift . buildDynamic a0

134134 {-# INLINABLE headE #-}

135135 headE = lift . headE

136+ {-# INLINABLE now #-}

137+ now = lift now

136138

137139instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where

138140 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

src/Reflex/PerformEvent/Base.hs+2

@@ -164,6 +164,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

164164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'

165165 {-# INLINABLE headE #-}

166166 headE = PerformEventT . lift . headE

167+ {-# INLINABLE now #-}

168+ now = PerformEventT . lift $ now

167169

168170instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

169171 type Ref (PerformEventT t m) = Ref (HostFrame t)

src/Reflex/PostBuild/Base.hs+2

@@ -84,6 +84,8 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

8484 buildDynamic a0 = lift . buildDynamic a0

8585 {-# INLINABLE headE #-}

8686 headE = lift . headE

87+ {-# INLINABLE now #-}

88+ now = lift now

8789

8890instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

8991 type Performable (PostBuildT t m) = Performable m

src/Reflex/Profiled.hs+1

@@ -183,6 +183,7 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where

183183 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

184184 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'

185185 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

186+ now = ProfiledM $ Event_Profiled <$> now

186187

187188instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

188189 sample (Behavior_Profiled b) = ProfiledM $ sample b

src/Reflex/Pure.hs+4

@@ -210,3 +210,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

210210 Just x -> fromMaybe lastValue $ apply x lastValue

211211

212212 headE = slowHeadE

213+ now t = Event $ guard . (t ==)

214+

215+

216+

src/Reflex/Spider/Internal.hs+36−1

@@ -306,7 +306,20 @@ data CacheSubscribed x a

306306#endif

307307 }

308308

309−

309+nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())

310+nowSpiderEventM =

311+ SpiderEvent <$> now

312+

313+now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x

314+ ) => m (Event x ())

315+now = do

316+ nowOrNot <- liftIO $ newIORef $ Just ()

317+ scheduleClear nowOrNot

318+ return . Event $ \_ -> do

319+ occ <- liftIO . readIORef $ nowOrNot

320+ return ( EventSubscription (return ()) eventSubscribedNow

321+ , occ

322+ )

310323

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

312325-- repeatedly

@@ -593,6 +606,16 @@ eventSubscribedNever = EventSubscribed

593606 , eventSubscribedWhoCreated = return ["never"]

594607#endif

595608 }

609+eventSubscribedNow :: EventSubscribed x

610+eventSubscribedNow = EventSubscribed

611+ { eventSubscribedHeightRef = zeroRef

612+ , eventSubscribedRetained = toAny ()

613+#ifdef DEBUG_CYCLES

614+ , eventSubscribedGetParents = return []

615+ , eventSubscribedHasOwnHeightRef = False

616+ , eventSubscribedWhoCreated = return ["now"]

617+#endif

618+ }

596619

597620eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

598621eventSubscribedFan !subscribed = EventSubscribed

@@ -2496,6 +2519,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

24962519 {-# INLINABLE headE #-}

24972520 headE = R.slowHeadE

24982521-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2522+ {-# INLINABLE now #-}

2523+ now = nowSpiderEventM

24992524

25002525instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

25012526 {-# INLINABLE sample #-}

@@ -2517,6 +2542,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

25172542 {-# INLINABLE headE #-}

25182543 headE = R.slowHeadE

25192544-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2545+ {-# INLINABLE now #-}

2546+ now = SpiderPushM nowSpiderEventM

2547+

25202548

25212549instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

25222550 {-# INLINE return #-}

@@ -2580,6 +2608,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

25802608 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

25812609 {-# INLINABLE headE #-}

25822610 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2611+ {-# INLINABLE now #-}

2612+ now = runFrame . runSpiderHostFrame $ Reflex.Class.now

2613+

25832614

25842615instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

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

@@ -2596,6 +2627,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

25962627 {-# INLINABLE headE #-}

25972628 headE = R.slowHeadE

25982629-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2630+ {-# INLINABLE now #-}

2631+ now = SpiderHostFrame Reflex.Class.now

25992632

26002633instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

26012634 {-# INLINABLE sample #-}

@@ -2616,6 +2649,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

26162649 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

26172650 {-# INLINABLE headE #-}

26182651 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2652+ {-# INLINABLE now #-}

2653+ now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now

26192654

26202655--------------------------------------------------------------------------------

26212656-- Deprecated items

src/Reflex/TriggerEvent/Base.hs+2

@@ -122,6 +122,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

122122 buildDynamic a0 = lift . buildDynamic a0

123123 {-# INLINABLE headE #-}

124124 headE = lift . headE

125+ {-# INLINABLE now #-}

126+ now = lift now

125127

126128instance Adjustable t m => Adjustable t (TriggerEventT t m) where

127129 {-# INLINABLE runWithReplace #-}

test/Reflex/Plan/Pure.hs+1

@@ -41,6 +41,7 @@ instance MonadHold (Pure Int) PurePlan where

4141 holdIncremental initial = liftPlan . holdIncremental initial

4242 buildDynamic getInitial = liftPlan . buildDynamic getInitial

4343 headE = liftPlan . headE

44+ now = liftPlan now

4445

4546instance MonadSample (Pure Int) PurePlan where

4647 sample = liftPlan . sample

test/Reflex/Test/Micro.hs+8−2

@@ -322,8 +322,14 @@ testCases =

322322 let e = never <$ switch b

323323 return $ void e

324324 lazyHold

325−

326−

325+ , testE "now-1" $ do

326+ e1 <- events1

327+ switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1

328+ , testE "now-2" $ do

329+ e1 <- events1

330+ let e = pushAlways (\a -> if a == "a" then now else return never) e1

331+ x <- accumDyn (<>) never e

332+ return . coincidence $ updated x

327333 ] where

328334

329335 events1, events2, events3 :: TestPlan t m => m (Event t String)