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

ChangeLog.md

@@ -1,5 +1,8 @@
 # Revision history for reflex
 
+## Unreleased
+* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.
+
 ## 0.7.1.0
 
 * ([#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

@@ -420,6 +420,13 @@ class MonadSample t m => MonadHold t m where
   -- | Create a new 'Event' that only occurs only once, on the first occurrence of
   -- the supplied 'Event'.
   headE :: Event t a -> m (Event t a)
+  -- | An event which only occurs at the current moment in time, such that:
+  --
+  -- > coincidence (pushAlways (\a -> (a <$) <$> now) e) = e
+  --
+  now :: m (Event t ())
+  default now :: (m ~ f m', MonadTrans f, MonadHold t m') => m (Event t ())
+  now = lift now
 
 -- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',
 -- using the combining function to produce a patch.
@@ -565,6 +572,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
   holdIncremental a0 = lift . holdIncremental a0
   buildDynamic a0 = lift . buildDynamic a0
   headE = lift . headE
+  now = lift now
 
 instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
   sample = lift . sample
@@ -575,6 +583,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
   holdIncremental a0 = lift . holdIncremental a0
   buildDynamic a0 = lift . buildDynamic a0
   headE = lift . headE
+  now = lift now
 
 instance MonadSample t m => MonadSample t (StateT s m) where
   sample = lift . sample
@@ -585,6 +594,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where
   holdIncremental a0 = lift . holdIncremental a0
   buildDynamic a0 = lift . buildDynamic a0
   headE = lift . headE
+  now = lift now
 
 instance MonadSample t m => MonadSample t (ExceptT e m) where
   sample = lift . sample
@@ -595,6 +605,7 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where
   holdIncremental a0 = lift . holdIncremental a0
   buildDynamic a0 = lift . buildDynamic a0
   headE = lift . headE
+  now = lift now
 
 instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
   sample = lift . sample
@@ -605,6 +616,7 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
   holdIncremental a0 = lift . holdIncremental a0
   buildDynamic a0 = lift . buildDynamic a0
   headE = lift . headE
+  now = lift now
 
 instance MonadSample t m => MonadSample t (ContT r m) where
   sample = lift . sample
@@ -615,6 +627,7 @@ instance MonadHold t m => MonadHold t (ContT r m) where
   holdIncremental a0 = lift . holdIncremental a0
   buildDynamic a0 = lift . buildDynamic a0
   headE = lift . headE
+  now = lift now
 
 --------------------------------------------------------------------------------
 -- Convenience functions

src/Reflex/EventWriter/Base.hs

@@ -133,6 +133,8 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
   buildDynamic a0 = lift . buildDynamic a0
   {-# INLINABLE headE #-}
   headE = lift . headE
+  {-# INLINABLE now #-}
+  now = lift now
 
 instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
   runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

src/Reflex/PerformEvent/Base.hs

@@ -164,6 +164,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
   buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
   {-# INLINABLE headE #-}
   headE = PerformEventT . lift . headE
+  {-# INLINABLE now #-}
+  now = PerformEventT . lift $ now
 
 instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
   type Ref (PerformEventT t m) = Ref (HostFrame t)

src/Reflex/PostBuild/Base.hs

@@ -84,6 +84,8 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where
   buildDynamic a0 = lift . buildDynamic a0
   {-# INLINABLE headE #-}
   headE = lift . headE
+  {-# INLINABLE now #-}
+  now = lift now
 
 instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
   type Performable (PostBuildT t m) = Performable m

src/Reflex/Profiled.hs

@@ -183,6 +183,7 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
   holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
   buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
   headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
+  now = ProfiledM $ Event_Profiled <$> now
 
 instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
   sample (Behavior_Profiled b) = ProfiledM $ sample b

src/Reflex/Pure.hs

@@ -210,3 +210,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
                    Just x -> fromMaybe lastValue $ apply x lastValue
 
   headE = slowHeadE
+  now t = Event $ guard . (t ==)
+
+
+

src/Reflex/Spider/Internal.hs

@@ -306,7 +306,20 @@ data CacheSubscribed x a
 #endif
                      }
 
-
+nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())
+nowSpiderEventM =
+  SpiderEvent <$> now
+
+now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x
+       ) => m (Event x ())
+now = do
+  nowOrNot <- liftIO $ newIORef $ Just ()
+  scheduleClear nowOrNot
+  return . Event $ \_ -> do
+    occ <- liftIO . readIORef $ nowOrNot
+    return ( EventSubscription (return ()) eventSubscribedNow
+           , occ
+           )
 
 -- | Construct an 'Event' whose value is guaranteed not to be recomputed
 -- repeatedly
@@ -593,6 +606,16 @@ eventSubscribedNever = EventSubscribed
   , eventSubscribedWhoCreated = return ["never"]
 #endif
   }
+eventSubscribedNow :: EventSubscribed x
+eventSubscribedNow = EventSubscribed
+  { eventSubscribedHeightRef = zeroRef
+  , eventSubscribedRetained = toAny ()
+#ifdef DEBUG_CYCLES
+  , eventSubscribedGetParents = return []
+  , eventSubscribedHasOwnHeightRef = False
+  , eventSubscribedWhoCreated = return ["now"]
+#endif
+  }
 
 eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
 eventSubscribedFan !subscribed = EventSubscribed
@@ -2496,6 +2519,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
   {-# INLINABLE headE #-}
   headE = R.slowHeadE
 --  headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
+  {-# INLINABLE now #-}
+  now = nowSpiderEventM
 
 instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
   {-# INLINABLE sample #-}
@@ -2517,6 +2542,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
   {-# INLINABLE headE #-}
   headE = R.slowHeadE
 --  headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
+  {-# INLINABLE now #-}
+  now = SpiderPushM nowSpiderEventM
+
 
 instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
   {-# INLINE return #-}
@@ -2580,6 +2608,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
   buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
   {-# INLINABLE headE #-}
   headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
+  {-# INLINABLE now #-}
+  now = runFrame . runSpiderHostFrame $ Reflex.Class.now
+
 
 instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
   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
   {-# INLINABLE headE #-}
   headE = R.slowHeadE
 --  headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
+  {-# INLINABLE now #-}
+  now = SpiderHostFrame Reflex.Class.now
 
 instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
   {-# INLINABLE sample #-}
@@ -2616,6 +2649,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
   buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
   {-# INLINABLE headE #-}
   headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
+  {-# INLINABLE now #-}
+  now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
 
 --------------------------------------------------------------------------------
 -- Deprecated items

src/Reflex/TriggerEvent/Base.hs

@@ -122,6 +122,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where
   buildDynamic a0 = lift . buildDynamic a0
   {-# INLINABLE headE #-}
   headE = lift . headE
+  {-# INLINABLE now #-}
+  now = lift now
 
 instance Adjustable t m => Adjustable t (TriggerEventT t m) where
   {-# INLINABLE runWithReplace #-}

test/Reflex/Plan/Pure.hs

@@ -41,6 +41,7 @@ instance MonadHold (Pure Int) PurePlan where
   holdIncremental initial = liftPlan . holdIncremental initial
   buildDynamic getInitial = liftPlan . buildDynamic getInitial
   headE = liftPlan . headE
+  now = liftPlan now
 
 instance MonadSample (Pure Int) PurePlan where
   sample = liftPlan . sample

test/Reflex/Test/Micro.hs

@@ -322,8 +322,14 @@ testCases =
                 let e = never <$ switch b
             return $ void e
       lazyHold
-
-
+  , testE "now-1" $ do
+      e1 <- events1
+      switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1
+  , testE "now-2" $ do
+      e1 <- events1
+      let e = pushAlways (\a -> if a == "a" then now else return never) e1
+      x <- accumDyn (<>) never e 
+      return . coincidence $ updated x
   ] where
 
     events1, events2, events3 ::  TestPlan t m => m (Event t String)