loopy.scm

   1 (define-module (loopy agenda)
   2   #:use-module (srfi srfi-9)
   3   #:use-module (srfi srfi-9 gnu)
   4   #:use-module (ice-9 q)
   5   #:use-module (ice-9 match)
   6   #:export (make-agenda
   7             agenda?
   8             agenda-queue agenda-prompt-tag
   9             agenda-port-pmapping agenda-schedule
  10
  11             make-async-prompt-tag
  12
  13             make-time-segment
  14             time-segment?
  15             time-segment-time time-segment-queue
  16
  17             time-< time-=
  18
  19             make-schedule
  20             schedule-add! schedule-empty?
  21
  22             make-port-mapping
  23             port-mapping-set! port-mapping-remove!
  24             port-mapping-empty? port-mapping-non-empty?
  25
  26             %current-agenda
  27             start-agenda agenda-run-once))
  28
  29 ;; @@: Using immutable agendas here, so wouldn't it make sense to
  30 ;;   replace this queue stuff with using pfds based immutable queues?
  31
  32 \f
  33 ;;; Agenda definition
  34 ;;; =================
  35
  36 ;;; The agenda consists of:
  37 ;;;  - a queue of immediate items to handle
  38 ;;;  - sheduled future events to be added to a future queue
  39 ;;;  - a tag by which running processes can escape for some asynchronous
  40 ;;;    operation (from which they can be returned later)
  41 ;;;  - a mapping of ports to various handler procedures
  42 ;;;
  43 ;;; The goal, eventually, is for this all to be immutable and functional.
  44 ;;; However, we aren't there yet.  Some tricky things:
  45 ;;;  - The schedule needs to be immutable, yet reasonably efficient.
  46 ;;;  - Need to use immutable queues (ijp's pfds library?)
  47 ;;;  - Modeling reading from ports as something repeatable,
  48 ;;;    and with reasonable separation from functional components?
  49
  50 (define-immutable-record-type <agenda>
  51   (make-agenda-intern queue prompt-tag port-mapping schedule)
  52   agenda?
  53   (queue agenda-queue)
  54   (prompt-tag agenda-prompt-tag)
  55   (port-mapping agenda-port-mapping)
  56   (schedule agenda-schedule))
  57
  58 (define (make-async-prompt-tag)
  59   (make-prompt-tag "prompt"))
  60
  61 (define* (make-agenda #:key
  62                       (queue (make-q))
  63                       (prompt (make-prompt-tag))
  64                       (port-mapping (make-port-mapping))
  65                       (schedule (make-schedule)))
  66   (make-agenda-intern queue prompt port-mapping schedule))
  67
  68
  69 \f
  70 ;;; Schedule
  71 ;;; ========
  72
  73 ;;; This is where we handle timed events for the future
  74
  75 ;; This section totally borrows from SICP
  76 ;; <3 <3 <3
  77
  78 ;; NOTE: time is a cons of (seconds . microseconds)
  79
  80 (define-record-type <time-segment>
  81   (make-time-segment-intern time queue)
  82   time-segment?
  83   (time time-segment-time)
  84   (queue time-segment-queue))
  85
  86 (define (time-segment-right-format time)
  87   (match time
  88     ;; time is already a cons of second and microsecnd
  89     (((? integer? s) (? integer? u)) time)
  90     ;; time was just an integer (just the second)
  91     ((? integer? _) (cons time 0))
  92     (_ (throw 'invalid-time "Invalid time" time))))
  93
  94 (define* (make-time-segment time #:optional (queue (make-q)))
  95   (make-time-segment-intern time queue))
  96
  97 (define (time-< time1 time2)
  98   (cond ((< (car time1)
  99             (car time2))
 100          #t)
 101         ((and (= (car time1)
 102                  (car time2))
 103               (< (cdr time1)
 104                  (cdr time2)))
 105          #t)
 106         (else #f)))
 107
 108 (define (time-= time1 time2)
 109   (and (= (car time1) (car time2))
 110        (= (cdr time1) (cdr time2))))
 111
 112 (define (make-schedule)
 113   '())
 114
 115 (define (schedule-add! time proc schedule)
 116   (let ((time (time-segment-right-format time)))
 117     (define (belongs-before? segments)
 118       (or (null? segments)
 119           (error))
 120     )
 121
 122   ;; Find and add a schedule segment
 123   (error)))
 124
 125 (define (schedule-empty? schedule)
 126   (eq? schedule '()))
 127
 128
 129 \f
 130 ;;; Port handling
 131 ;;; =============
 132
 133 (define (make-port-mapping)
 134   (make-hash-table))
 135
 136 (define* (port-mapping-set! port-mapping port #:optional read write except)
 137   "Sets port-mapping for reader / writer / exception handlers"
 138   (if (not (or read write except))
 139       (throw 'no-handlers-given "No handlers given for port" port))
 140   (hashq-set! port-mapping port
 141               `#(,read ,write ,except)))
 142
 143 (define (port-mapping-remove! port-mapping port)
 144   (hashq-remove! port-mapping port))
 145
 146 ;; TODO: This is O(n), I'm pretty sure :\
 147 ;; ... it might be worthwhile for us to have a
 148 ;;   port-mapping record that keeps a count of how many
 149 ;;   handlers (maybe via a promise?)
 150 (define (port-mapping-empty? port-mapping)
 151   "Is this port mapping empty?"
 152   (eq? (hash-count (const #t) port-mapping) 0))
 153
 154 (define (port-mapping-non-empty? port-mapping)
 155   "Whether this port-mapping contains any elements"
 156   (not (port-mapping-empty? port-mapping)))
 157
 158
 159 \f
 160 ;;; Execution of agenda, and current agenda
 161 ;;; =======================================
 162
 163 (define %current-agenda (make-parameter #f))
 164
 165 (define* (start-agenda agenda #:optional stop-condition)
 166   (let loop ((agenda agenda))
 167     (let ((new-agenda
 168            ;; @@: Hm, maybe here would be a great place to handle
 169            ;;   select'ing on ports.
 170            ;;   We could compose over agenda-run-once and agenda-read-ports
 171            (parameterize ((%current-agenda agenda))
 172              (agenda-run-once agenda))))
 173       (if (and stop-condition (stop-condition agenda))
 174           'done
 175           (loop new-agenda)))))
 176
 177 (define (agenda-run-once agenda)
 178   "Run once through the agenda, and produce a new agenda
 179 based on the results"
 180   (define (call-proc proc)
 181     (call-with-prompt
 182         (agenda-prompt-tag agenda)
 183       (lambda ()
 184         (proc))
 185       ;; TODO
 186       (lambda (k) k)))
 187
 188   (let ((queue (agenda-queue agenda))
 189         (next-queue (make-q)))
 190     (while (not (q-empty? queue))
 191       (let* ((proc (q-pop! queue))
 192              (proc-result (call-proc proc))
 193              (enqueue
 194               (lambda (new-proc)
 195                 (enq! next-queue new-proc))))
 196         ;; @@: We might support delay-wrapped procedures here
 197         (match proc-result
 198           ((? procedure? new-proc)
 199            (enqueue new-proc))
 200           (((? procedure? new-procs) ...)
 201            (for-each
 202             (lambda (new-proc)
 203               (enqueue new-proc))
 204             new-procs))
 205           ;; do nothing
 206           (_ #f))))
 207     ;; TODO: Selecting on ports would happen here?
 208     ;; Return new agenda, with next queue set
 209     (set-field agenda (agenda-queue) next-queue)))