forked from vv/bugafriend
67 lines
2.6 KiB
Scheme
67 lines
2.6 KiB
Scheme
;;; Copyright 2023 David Thompson
|
|
;;; Copyright 2024 Vivianne Langdon
|
|
;;; From Fantasary https://gitlab.com/spritely/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 ncurses vat)
|
|
#:use-module (bugafriend event-loop)
|
|
#:use-module (fibers channels)
|
|
#:use-module (goblins vat)
|
|
#:use-module (ice-9 atomic)
|
|
#:export (make-ncurses-vat
|
|
spawn-ncurses-vat))
|
|
|
|
;; There's nothing specific to ncurses in here, but this vat
|
|
;; integrates well with our event loop that uses ncurses.
|
|
(define* (make-ncurses-vat tasks #:key (name "ncurses") (log? #f))
|
|
(define box:running? (make-atomic-box #f))
|
|
(define box:churn (make-atomic-box #f))
|
|
(define (churn envelope)
|
|
((atomic-box-ref box:churn) envelope))
|
|
(define (start churn)
|
|
(atomic-box-set! box:running? #t)
|
|
(atomic-box-set! box:churn churn))
|
|
(define (halt)
|
|
(atomic-box-set! box:running? #f)
|
|
(atomic-box-set! box:churn #f))
|
|
(define (send envelope)
|
|
(cond
|
|
;; Message is being sent from outside of the current task queue
|
|
;; context, so use a channel to synchronize passing back a return
|
|
;; value.
|
|
((and (vat-envelope-return? envelope)
|
|
(not (eq? tasks (current-task-queue))))
|
|
(let ((return-channel (make-channel)))
|
|
(add-task! tasks
|
|
(lambda ()
|
|
(put-message return-channel (churn envelope))))
|
|
(get-message return-channel)))
|
|
;; Message is being sent from within the current task queue
|
|
;; context, so process immediately and return the result.
|
|
((vat-envelope-return? envelope)
|
|
(churn envelope))
|
|
;; Caller does not care about the return value, so just add it
|
|
;; to the task queue for processing later.
|
|
(else
|
|
(add-task! tasks (lambda () (churn envelope))))))
|
|
(make-vat #:name name
|
|
#:log? log?
|
|
#:start start
|
|
#:halt halt
|
|
#:send send))
|
|
|
|
(define* (spawn-ncurses-vat tasks #:key (name "ncurses") (log? #f))
|
|
(let ((vat (make-ncurses-vat tasks #:name name #:log? log?)))
|
|
(vat-start! vat)
|
|
vat))
|