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

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

(require syndicate/driver-support)
(require syndicate/engine)
(require syndicate/schemas/gen/timer)
(require syndicate/schemas/gen/dataspace-patterns)
(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))))
               (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 msecs (TimerKind-relative))
                              (define deadline (+ (current-inexact-milliseconds) msecs))
                              (install-timer! label deadline)
                              (loop)]
                             [(SetTimer label deadline (TimerKind-absolute))
                              (install-timer! label deadline)
                              (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 ,(DLit $msecs))) _)
      (log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
                                         msecs
                                         (current-inexact-milliseconds))
      (define timer-id (gensym 'timestate))
      (on-start (send! (SetTimer timer-id msecs (TimerKind-absolute))))
      (on-stop  (send! (SetTimer timer-id msecs (TimerKind-clear))))
      (on (message (TimerExpired timer-id _))
        (react (assert (LaterThan msecs)))))))

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