85 lines
2.8 KiB
Scheme
85 lines
2.8 KiB
Scheme
;;; Copyright 2023 David Thompson
|
|
;;; Copyright 2023 Christine Lemmer-Webber
|
|
;;; Copyright 2024 Vivianne Langdon
|
|
;;; From Fantasary
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
(define-module (bugafriend event-loop)
|
|
#:use-module (bugafriend utils concurrent-queue)
|
|
#:use-module (bugafriend ncurses stuff)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ncurses curses)
|
|
#:use-module (system repl coop-server)
|
|
#:export (current-task-queue
|
|
add-task!
|
|
run-event-loop
|
|
halt-event-loop))
|
|
|
|
(define useconds-per-second 1000000)
|
|
;; Ratio for converting high resolution timer values to microseconds.
|
|
(define internal-time-divisor
|
|
(/ internal-time-units-per-second useconds-per-second))
|
|
|
|
(define (current-time)
|
|
(truncate-quotient (get-internal-run-time) internal-time-divisor))
|
|
|
|
(define (add-task! tasks thunk)
|
|
(concurrent-enqueue! tasks thunk))
|
|
|
|
(define current-task-queue (make-parameter #f))
|
|
(define event-loop-prompt (make-prompt-tag 'event-loop))
|
|
(define no-op (lambda _ 'no-op))
|
|
|
|
(define* (run-event-loop #:key
|
|
(init no-op)
|
|
(handle-input no-op)
|
|
(screen (screen-setup!))
|
|
(tasks (make-concurrent-queue))
|
|
repl
|
|
(hz 60))
|
|
(define tick-usecs (truncate-quotient useconds-per-second hz))
|
|
(define (consume-all-input)
|
|
(match (getch screen)
|
|
(#f 'done)
|
|
(input
|
|
(handle-input screen input)
|
|
(consume-all-input))))
|
|
(define (process-all-tasks)
|
|
(unless (concurrent-queue-empty? tasks)
|
|
(let ((thunk (concurrent-dequeue! tasks)))
|
|
(when (procedure? thunk)
|
|
(thunk)))
|
|
(process-all-tasks)))
|
|
(define (event-loop)
|
|
(define last-usecs (current-time))
|
|
(consume-all-input)
|
|
(process-all-tasks)
|
|
(when repl
|
|
(poll-coop-repl-server repl))
|
|
(let* ((before-sleep (current-time))
|
|
(delay-usecs (max (- (+ last-usecs tick-usecs) before-sleep) 0)))
|
|
(usleep delay-usecs))
|
|
(event-loop))
|
|
(define (boot)
|
|
(call-with-prompt event-loop-prompt
|
|
(lambda ()
|
|
(parameterize ((current-task-queue tasks))
|
|
(init screen)
|
|
(event-loop)))
|
|
(lambda (_k) #t))
|
|
(endwin))
|
|
(boot))
|
|
|
|
(define (halt-event-loop)
|
|
(abort-to-prompt event-loop-prompt))
|