#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2018-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

(provide (all-from-out syndicate/schemas/timer)
         timeout)

(require syndicate/driver-support)
(require syndicate/engine)
(require syndicate/schemas/timer)
(require syndicate/schemas/dataspacePatterns)
(require data/heap)

(define-logger syndicate/drivers/timer)

(provide-service [ds]
  (define control-ch (make-channel))

  (linked-thread
   #:name 'timer-driver-thread
   (lambda (facet)
     (struct pending-timer (deadline label) #:transparent)

     (define engine (actor-engine (facet-actor facet)))

     (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)
               (turn! facet (lambda () (send! ds (TimerExpired label (/ now 1000.0)))))
               (set! count-fired (+ count-fired 1))
               (loop)))))
       (adjust-inhabitant-count! engine (- 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)
          (adjust-inhabitant-count! engine -1)]))

     (define (install-timer! label deadline)
       (clear-timer! label)
       (heap-add! heap (pending-timer deadline label))
       (hash-set! timers label deadline)
       (adjust-inhabitant-count! engine 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
                         (lambda (m)
                           (match (parse-SetTimer m)
                             [(SetTimer label _ (TimerKind-clear))
                              (clear-timer! label)
                              (loop)]
                             [(SetTimer label secs (TimerKind-relative))
                              (define deadline (+ (current-inexact-milliseconds) (* 1000.0 secs)))
                              (install-timer! label deadline)
                              (loop)]
                             [(SetTimer label deadline (TimerKind-absolute))
                              (install-timer! label (* deadline 1000.0))
                              (loop)])))))))

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

    (during (Observe (:pattern (LaterThan ,(Pattern-lit $seconds))) _)
      (log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
                                         seconds
                                         (/ (current-inexact-milliseconds) 1000.0))
      (define timer-id (gensym 'timestate))
      (on-start (send! (SetTimer timer-id seconds (TimerKind-absolute))))
      (on-stop  (send! (SetTimer timer-id seconds (TimerKind-clear))))
      (on (message (TimerExpired timer-id _))
        (react (assert (LaterThan seconds)))))))

(define-event-expander timeout
  (syntax-rules ()
    [(_ [relative-seconds] body ...)
     (let ((timer-id (gensym 'timeout)))
       (on-start (send! (SetTimer timer-id relative-seconds (TimerKind-relative))))
       (on (message (TimerExpired timer-id _)) body ...))]))