loopy.scm

   1 (use-modules (srfi srfi-9)
   2              (srfi srfi-9 gnu)
   3              (ice-9 q)
   4              (ice-9 match))
   5
   6 ;; @@: Using immutable agendas here, so wouldn't it make sense to
   7 ;;   replace this
   8
   9 (define-immutable-record-type <agenda>
  10   (make-agenda-intern queue prompt-tag)
  11   agenda?
  12   (queue agenda-queue)
  13   (prompt-tag agenda-prompt-tag))
  14
  15 (define (make-async-prompt-tag)
  16   (make-prompt-tag "prompt"))
  17
  18 (define* (make-agenda #:key
  19                       (queue (make-q))
  20                       (prompt (make-prompt-tag)))
  21   (make-agenda-intern queue prompt))
  22
  23 (define %current-agenda (make-parameter #f))
  24
  25 (define* (start-agenda agenda #:optional stop-condition)
  26   (let loop ((agenda agenda))
  27     (let ((new-agenda
  28            (parameterize ((%current-agenda agenda))
  29              (agenda-run-once agenda))))
  30       (if (and stop-condition (stop-condition agenda))
  31           'done
  32           (loop new-agenda)))))
  33
  34 (define (agenda-run-once agenda)
  35   "Run once through the agenda, and produce a new agenda
  36 based on the results"
  37   (define (call-proc proc)
  38     (call-with-prompt
  39         (agenda-prompt-tag agenda)
  40       (lambda ()
  41         (proc))
  42       ;; TODO
  43       (lambda (k) k)))
  44
  45   (let ((queue (agenda-queue agenda))
  46         (next-queue (make-q)))
  47     (while (not (q-empty? queue))
  48       (let* ((proc (q-pop! queue))
  49              (proc-result (call-proc proc))
  50              (enqueue
  51               (lambda (new-proc)
  52                 (enq! next-queue new-proc))))
  53         ;; @@: We might support delay-wrapped procedures here
  54         (match proc-result
  55           ((? procedure? new-proc)
  56            (enqueue new-proc))
  57           (((? procedure? new-procs) ...)
  58            (for-each
  59             (lambda (new-proc)
  60               (enqueue new-proc))
  61             new-procs)))))
  62     ;; TODO: Selecting on ports would happen here?
  63     ;; Return new agenda, with next queue set
  64     (set-field agenda (agenda-queue) next-queue)))