#lang racket/base

(require racket/match)
(require "codec.rkt")
(require "os-big-bang.rkt")
(require "os-udp.rkt")

(provide (struct-out set-timer)
	 (struct-out timer-expired)
	 timer-driver
	 timer-relay)

(struct set-timer (label msecs relative?) #:prefab)
(struct timer-expired (label msecs) #:prefab)

;; Something like this should be part of racket
(define (timer-evt msecs relative?)
  (wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
	    (lambda (_) (current-inexact-milliseconds))))

(define (timer-driver [self-id 'timer-driver])
  (os-big-bang 'no-state
    (subscribe 'timer-setter
      (message-handlers w
	[(set-timer reply-label msecs relative?)
	 (transition w
	   (subscribe/fresh label
	     (ground-message-handler w
	       [((list self-id label)
		 (timer-evt msecs relative?)
		 => now)
		(transition w
		  (unsubscribe label)
		  (send-message (timer-expired reply-label now)))])))]))))

(define (timer-relay [self-id 'timer-relay])
  (os-big-bang 'no-state
    (subscribe 'timer-relay
      (message-handlers w
	[(set-timer reply-label msecs relative?)
	 (define timer-id (list self-id reply-label))
	 (transition w
	   (send-meta-message (set-timer timer-id msecs relative?))
	   (subscribe/fresh label
	     (meta-message-handlers w
	       [(timer-expired (== timer-id) now)
		(transition w
		  (unsubscribe label)
		  (send-message (timer-expired reply-label now)))])))]))))