#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)
         spawn-timer-driver
         on-timeout
         stop-when-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)

(define (spawn-timer-driver ds)
  (spawn
    #:name 'timer-driver
    #:daemon? #t

    (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
      (when (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! ds (SetTimer timer-id msecs (TimerKind-absolute))))
        (on-stop  (send! ds (SetTimer timer-id msecs (TimerKind-clear))))
        (at ds
          (when (message (TimerExpired timer-id _))
            (react (at ds (assert (LaterThan msecs))))))))))

(define-syntax-rule (on-timeout relative-msecs body ...)
  (let ((timer-id (gensym 'timeout)))
    (on-start (send! this-target (SetTimer timer-id relative-msecs (TimerKind-relative))))
    (at this-target
      (when (message (TimerExpired timer-id _))
        body ...))))

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