2017-08-10 19:17:28 +00:00
|
|
|
#lang syndicate
|
2016-10-31 21:36:59 +00:00
|
|
|
|
|
|
|
(provide (struct-out later-than)
|
2017-11-13 15:29:48 +00:00
|
|
|
on-timeout
|
2016-11-20 22:51:48 +00:00
|
|
|
stop-when-timeout
|
|
|
|
sleep)
|
2016-10-31 21:36:59 +00:00
|
|
|
|
|
|
|
(require/activate syndicate/drivers/timer)
|
|
|
|
|
|
|
|
(struct later-than (msecs) #:prefab)
|
|
|
|
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn #:name 'drivers/timestate
|
2016-10-31 21:36:59 +00:00
|
|
|
(during (observe (later-than $msecs))
|
|
|
|
(define timer-id (gensym 'timestate))
|
|
|
|
(on-start (send! (set-timer timer-id msecs 'absolute)))
|
2017-09-28 16:07:32 +00:00
|
|
|
(on (message (timer-expired timer-id _))
|
|
|
|
(react (assert (later-than msecs))))))
|
2016-10-31 21:36:59 +00:00
|
|
|
|
2017-11-13 15:29:48 +00:00
|
|
|
(define-syntax-rule (on-timeout relative-msecs body ...)
|
2016-10-31 21:36:59 +00:00
|
|
|
(let ((timer-id (gensym 'timeout)))
|
|
|
|
(on-start (send! (set-timer timer-id relative-msecs 'relative)))
|
2017-11-13 15:29:48 +00:00
|
|
|
(on (message (timer-expired timer-id _)) body ...)))
|
|
|
|
|
|
|
|
(define-syntax-rule (stop-when-timeout relative-msecs body ...)
|
|
|
|
(on-timeout relative-msecs (stop-current-facet body ...)))
|
2016-11-20 22:51:48 +00:00
|
|
|
|
|
|
|
(define (sleep sec)
|
|
|
|
(define timer-id (gensym 'sleep))
|
|
|
|
(until (message (timer-expired timer-id _))
|
|
|
|
(on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
|