Reflex.Additions.hs

-- | Mask an event. The first parameter is the "masking event" that masks when
-- input events are forwarded to output events. The behavior constructed by
-- `stepper False mE` defines the masking period: When True, events can pass,
-- otherwise they are accumulated internally and can not pass.
-- As soon as the masking event switches from True to False, all accumulated
-- events get triggered simultaneously.
--     mask    *************         *******
--          ***             *********       *******
--     
--     eIn  v1   v2   v3             v4     v5
--     
--     eOut v1              v2       v4     v5
--                          v3
gateGather
  :: forall t a m
   . (Reflex t, MonadFix m, MonadHold t m)
  => Dynamic t Bool
  -> Event t a
  -> m (Event t [a])
gateGather maskDyn signalE = do
  let f :: [a] -> These Bool a -> (Maybe [a], Maybe [a])
      f xs       (That x       ) = (Just (x:xs), Nothing)           -- save event to delay, simple case
      f xs       (These True  x) = (Just (x:xs), Nothing)           -- masked before and after, save event to delay
      f xs       (These False x) = (Just [], Just $ reverse (x:xs)) -- falling edge -> input is delayed by 0, i.e. passed through
      f xs       (This False   ) = (Just [], Just $ reverse xs)     -- falling edge -> buffer is served
      f _        (This True    ) = (Nothing, Nothing)               -- no change
  let throughE  = gate (not <$> current maskDyn) $ (:[]) <$> signalE
  let bufferedE = gate (current maskDyn) signalE
  (_, delayedE) <- mapAccumMaybeB f [] $ align (updated maskDyn) bufferedE
  return $ mergeWith const [throughE, delayedE]


-- | Similar to gateGather, but throwing away every event but the latest from the
-- internal accumulator. Semantically, it should hold that
-- `maskCalmE m e == calm . gateGather m e`.
-- This method is more efficient however, as the accumulator only holds a
-- single element, preventing the potential space leak.
--     mask    *************                *******
--          ***             ****************       *****
--     
--     eIn  v1   v2   v3             v4     v5     v6
--     
--     eOut v1              v3       v4     v5     v6
maskCalmE
  :: forall t a m
   . (Reflex t, MonadFix m, MonadHold t m)
  => Dynamic t Bool
  -> Event t a
  -> m (Event t a)
maskCalmE maskDyn signalE = do
  let f :: Maybe a -> These Bool a -> (Maybe (Maybe a), Maybe a)
      f _        (That x       ) = (Just (Just x), Nothing) -- save event to delay, simple case, potentially overwrite
      f _        (These True  x) = (Just (Just x), Nothing) -- masked before and after, save event to delay
      f Nothing  (These False x) = (Nothing, Just x)        -- falling edge -> input is delayed by 0, i.e. passed through
      f (Just _) (These False x) = (Just Nothing, Just x)   -- falling edge -> input is delayed by 0, i.e. passed through
      f (Just x) (This False   ) = (Just Nothing, Just x)   -- falling edge -> buffer is served
      f _        (This _       ) = (Nothing, Nothing)       -- no change
  let (throughE, bufferedE) = fanOn (current maskDyn) signalE
  (_, delayedE) <- mapAccumMaybeB f Nothing $ align (updated maskDyn) bufferedE
  return $ mergeWith const [throughE, delayedE]


-- | Somewhat similar to `maskCalmE`, but separating the "when to retain" and
-- the "when to release" logic to prevent logic loops.
-- If the input behaviour is true ("masked"), input events set or replace
-- the buffer contents; otherwise it is passed through to the output.
-- If the release event fires, the buffer is released (fired as output, buffer
-- is cleared).
-- The coincidence of signal event and release event leads has non-trivial
-- semantics: If the mask is true, this function effectively swaps
-- (output is fired with value from buffer, buffer gets input). If mask is
-- false, there are two events designated as "output" in this frame, and this
-- function prefers to pass the input event through (buffer gets dropped).
--
--     mask        *************            ***************
--              ***             ************               ********
--     release           .            .   .     .   .       .   .
--     signal   v1   v2      v3  v4          v5 v6      v7  v8
--     output   v1       v2      v4   v3        v5  v6      v8
--                                              ^           ^
--                                            swap     input overrides
conditionalBuffer
  :: (Reflex t, MonadHold t m)
  => Behavior t Bool
  -> Event t ()
  -> Event t a
  -> m (Event t a)
conditionalBuffer maskB releaseE signalE = do
  let (throughE, bufferedE) = fanOn maskB signalE
  bufferB <- hold Nothing
    $ mergeWith const [Just <$> bufferedE, Nothing <$ releaseE]
  let releasedE = attachWithMaybe const bufferB releaseE
  pure $ mergeWith const [throughE, releasedE]


-- | splits input event according to predicate
-- > (eventsWhenFalse, eventWhenTrue) = fanOn pred inputE
fanBy :: Reflex t => (a -> Bool) -> Event t a -> (Event t a, Event t a)
fanBy f e = fanEither $ e <&> \x -> if f x then Right x else Left x

-- | splits input event according to the behavior.
-- > (eventsWhenFalse, eventWhenTrue) = fanOn boolBeh inputE
fanOn :: Reflex t => Behavior t Bool -> Event t a -> (Event t a, Event t a)
fanOn b e = fanEither $ attachWith (bool Left Right) b e


-- | Delays, but not by some constant time but instead triggered by the
-- occurences of a "trigger" event.
--
-- The current implementation uses a simple list and therefor has non-optimal
-- performance - a Deque would behave better.
-- 
--     trigger .           .     .  .  . .  .      .
--     signal     v1    v2    v3         v4 v5 v6
--     output              v1    v2 v3   v4 v5     v6
triggerDelay
  :: forall t a m
   . (Reflex t, MonadHold t m, MonadFix m)
  => Event t ()
  -> Event t a
  -> m (Event t a)
triggerDelay trigger signal = do
  let takeBack :: [a] -> ([a], Maybe a)
      takeBack l = case reverse l of
        [] -> ([], Nothing)
        (x:xs) -> (reverse xs, Just x)
  accB <- accumB (flip id) ([], Nothing)
           $ mergeWith (.)
                       [ const (takeBack . fst) <$> trigger
                       , (\e (l, _) -> (e:l, Nothing)) <$> signal
                       ]
  return $ fmapMaybe snd $ tag accB trigger

      
-- | Execute an action asynchronously, but never running more than one
-- computation in parallel; dropping older computations that got queued
-- for this reason. I.e. ensures that:
-- > for each (t1, input_i1) <- inputEvent
-- > there exists (t2, output_i2) <- outputEvent with with t2>t1, i2>=i1
-- > where `output_i :: a` is the finished computation
-- >       corresponding to `input_i :: IO a`.
-- and:
-- > for (t1, output_i1) and (t2, output_i2) holds that
-- >   t2>t1 <=> i2>i1
executeAsync1Calm
  :: forall t m a
   . ( MonadFix m
     , MonadHold t m
     , TriggerEvent t m
     , PerformEvent t m
     , MonadIO (Performable m)
     )
  => Event t (IO a)
  -> m (Event t (), Event t a)
     -- ^ "actually started" event, finished action event
executeAsync1Calm = executeAsync1CalmWith (void . forkIO)

-- | Same as 'executeAsync1CalmWith' but with a custom forking function
-- (parameterizing over `forkIO`).
executeAsync1CalmWith
  :: forall t m a
   . ( MonadFix m
     , MonadHold t m
     , TriggerEvent t m
     , PerformEvent t m
     , MonadIO (Performable m)
     )
  => (IO () -> IO ())
  -> Event t (IO a)
  -> m (Event t (), Event t a)
     -- ^ "actually started" event, finished action event
executeAsync1CalmWith forker e1 = mdo
  blockB :: Behavior t Bool <- hold False
    (mergeWith const [True <$ calc, False <$ resultE])
  calc :: Event t (IO a) <- conditionalBuffer blockB (void resultE) e1
  resultE <- performEventAsync $ calc <&> \m handler ->
    liftIO $ forker $ m >>= handler
  return (void calc, resultE)


-- | Simple "time-controlled gate".
-- This is a less permissive version of Reflex's `throttle`. Throttled events
-- are dropped completely, with no delayed fireing of the last throttled event.
--
-- Typical use-case is de-bouncing an input event containing small bursts of
-- occurences to a single occurence. 'throttle' does not work as it would
-- produce two occurences for each burst.
--
--     input   . . . . . . .      .        .. . .            ..
--     output  .       .          .        .                 .
--             <-----> (t/length of gate)
gateThrottle
  :: ( MonadHold t m
     , MonadFix m
     , TriggerEvent t m
     , PerformEvent t m
     , MonadIO (Performable m)
     )
  => NominalDiffTime
  -> Event t a
  -> m (Event t a)
gateThrottle t inE = mdo
  e <- delay t inE
  let out = gate b inE
  b <- hold True $ mergeWith const [False <$ out, True <$ e]
  return out