;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

#lang syndicate
;; Timer driver.

;; Uses mutable state internally, but because the scope of the
;; mutation is limited to each timer process alone, it's easy to show
;; correct linear use of the various pointers.

(provide (struct-out set-timer)
	 (struct-out timer-expired)
         (struct-out later-than)
         on-timeout
         stop-when-timeout
         sleep)

(define-logger syndicate/drivers/timer)

(require racket/set)
(require data/heap)

(message-struct set-timer (label msecs kind))
(message-struct timer-expired (label msecs))

(assertion-struct later-than (msecs))

(spawn #:name 'drivers/timer
       (define control-ch (make-channel))

       (thread (lambda ()
                 (struct pending-timer (deadline label) #:transparent)

                 (define heap
                   (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1)
                                                  (pending-timer-deadline t2)))))

                 (define timers (make-hash))

                 (define (next-timer)
                   (and (positive? (heap-count heap))
                        (heap-min heap)))

                 (define (fire-timers! now)
                   (define count-fired 0)
                   (let loop ()
                     (when (positive? (heap-count heap))
                       (let ((m (heap-min heap)))
                         (when (<= (pending-timer-deadline m) now)
                           (define label (pending-timer-label m))
                           (heap-remove-min! heap)
                           (hash-remove! timers label)
                           (log-syndicate/drivers/timer-debug "expired timer ~a" label)
                           (ground-send! (timer-expired label now))
                           (set! count-fired (+ count-fired 1))
                           (loop)))))
                   (signal-background-activity! (- count-fired)))

                 (define (clear-timer! label)
                   (match (hash-ref timers label #f)
                     [#f (void)]
                     [deadline
                      (heap-remove! heap (pending-timer deadline label))
                      (hash-remove! timers label)
                      (signal-background-activity! -1)]))

                 (define (install-timer! label deadline)
                   (clear-timer! label)
                   (heap-add! heap (pending-timer deadline label))
                   (hash-set! timers label deadline)
                   (signal-background-activity! +1))

                 (let loop ()
                   (sync (match (next-timer)
                           [#f never-evt]
                           [t (handle-evt (alarm-evt (pending-timer-deadline t))
                                          (lambda (_dummy)
                                            (define now (current-inexact-milliseconds))
                                            (fire-timers! now)
                                            (loop)))])
                         (handle-evt control-ch
                                     (match-lambda
                                       [(set-timer label _ 'clear)
                                        (clear-timer! label)
                                        (loop)]
                                       [(set-timer label msecs 'relative)
                                        (define deadline (+ (current-inexact-milliseconds) msecs))
                                        (install-timer! label deadline)
                                        (loop)]
                                       [(set-timer label deadline 'absolute)
                                        (install-timer! label deadline)
                                        (loop)]))))))

       (on (message ($ instruction (set-timer _ _ _)))
           (log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
           (channel-put control-ch instruction))

       (during (observe (later-than $msecs))
         (log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
                                            msecs
                                            (current-inexact-milliseconds))
         (define timer-id (gensym 'timestate))
         (on-start (send! (set-timer timer-id msecs 'absolute)))
         (on-stop (send! (set-timer timer-id msecs 'clear)))
         (on (message (timer-expired timer-id _))
             (react (assert (later-than msecs))))))

(define-syntax-rule (on-timeout relative-msecs body ...)
  (let ((timer-id (gensym 'timeout)))
    (on-start (send! (set-timer timer-id relative-msecs 'relative)))
    (on (message (timer-expired timer-id _)) body ...)))

(define-syntax-rule (stop-when-timeout relative-msecs body ...)
  (on-timeout relative-msecs (stop-current-facet body ...)))

(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)))))