Last active
March 16, 2020 10:11
-
-
Save lspitzner/18e679006765b308e9dbc41b06e86bbb to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- | 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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment