reactive-banana throttling events

gistfile1.hs

{-----------------------------------------------------------------------------
    
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"

import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX

{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}

data ThrottledValue a = FireStoredValue a | FireNowAndStartTimer a| HoldIt a | Stopped deriving Show
data ThrottledEvent a = TimerEvent | RealEvent a deriving Show

main :: IO ()
main = start $ do
    f   <- frame [text := "Countercesss"]
    sl1  <- hslider f False 0 100 []
    sl2  <- hslider f False 0 100 []
    set f [ layout := column 0 [widget sl1, widget sl2] ]
    t <- timer f []
    set t [ enabled := False ] 
    let networkDescription :: forall t. NetworkDescription t ()
        networkDescription = do
        slEv <- event0 sl1 command
        tick <- event0 t command 
        slB <- behavior sl1 selection
        throttledEv <- throttle (slB <@ slEv) tick t 100
        reactimate $ fmap (\x ->  set sl2 [selection := x]) throttledEv       
    net <- compile networkDescription
    actuate net            
    
throttle::Event t a -> Event t () -> Timer -> Int -> NetworkDescription t (Event t a)    
throttle ev tick timer dt = do
        reactimate $ filterJust $ fmap stop result   
        reactimate $ filterJust $ fmap start result
        return throttledEv
        where   
        all = fmap RealEvent ev `union` fmap (const TimerEvent) tick
        result = accumE Stopped $ fmap h all
                where
                h (RealEvent x) Stopped = FireNowAndStartTimer x
                h TimerEvent Stopped = Stopped
                h (RealEvent x) (FireNowAndStartTimer _) = HoldIt x
                h TimerEvent (FireNowAndStartTimer _) = Stopped
                h (RealEvent x) (HoldIt _) = HoldIt x
                h (TimerEvent) (HoldIt y) = FireStoredValue y
                h (RealEvent x) (FireStoredValue _) = HoldIt x
                h (TimerEvent) (FireStoredValue _) = Stopped          
        start (FireStoredValue _) = Just $ resetTimer timer dt
        start (FireNowAndStartTimer _) = Just $ resetTimer timer dt
        start _ = Nothing  
        stop Stopped = Just $ stopTimer timer
        stop _ = Nothing  
        filterFired (FireStoredValue a) = Just a
        filterFired (FireNowAndStartTimer a) = Just a
        filterFired _ = Nothing
        throttledEv = filterJust $ fmap filterFired result                 
            
startTimer :: Timer -> Int -> IO ()
startTimer t dt = set t [ enabled := True, interval := dt ]

stopTimer :: Timer -> IO ()
stopTimer t = set t [ enabled := False ]

resetTimer t dt = stopTimer t >> startTimer t dt