(module throttle mzscheme
(require (lib "contract.ss")
(lib "plt-match.ss")
(lib "cut.ss" "srfi" "26"))
(require (file "base.ss"))
(define-struct throttle (thread-descriptor delay start-channel finish-channel) #f)
(define (make-throttle-evt delay)
(alarm-evt (+ (current-inexact-milliseconds) delay)))
(define (create-throttle delay)
(letrec ([start (make-channel)]
[finish (make-channel)]
[loop (lambda ()
(channel-put (channel-get start) #t)
(channel-get finish)
(sync (make-throttle-evt delay))
(loop))]
[descriptor (thread loop)])
(make-throttle descriptor delay start finish)))
(define (kill-throttle! throttle)
(if (throttle-alive? throttle)
(let ([descriptor (throttle-thread-descriptor throttle)])
(kill-thread descriptor))
(raise-exn exn:fail:contract
(format "The throttle has been killed: ~a" throttle))))
(define (throttle-alive? throttle)
(not (thread-dead? (throttle-thread-descriptor throttle))))
(define (call-with-throttle throttle thunk)
(if (throttle-alive? throttle)
(let ([start (throttle-start-channel throttle)]
[finish (throttle-finish-channel throttle)]
[response (make-channel)])
(dynamic-wind
(lambda ()
(channel-put start response)
(channel-get response))
thunk
(lambda ()
(channel-put finish #t))))
(raise-exn exn:fail:contract
(format "The throttle has been killed: ~a" throttle))))
(provide throttle?)
(provide/contract
[rename create-throttle make-throttle (-> (and/c integer? (>=/c 0)) throttle?)]
[throttle-delay (-> throttle? integer?)]
[throttle-alive? (-> throttle? boolean?)]
[kill-throttle! (-> throttle? void?)]
[call-with-throttle (-> throttle? procedure? any)])
)