scheme coroutines

coro.scm

(define (msg-type msg)
  (cdr (assoc 'type msg)))

(define (msg-class msg)
  (cdr (assoc 'class msg)))

(define (msg-data msg)
  (cdr (assoc 'data msg)))

(define (msg-cmd msg)
  (cdr (assoc 'command msg)))

(define ((is-msg-class? class) msg)
  (and (string=? (msg-type msg) "msg")
       (string=? (msg-class msg) class)))

(define-syntax await
  (er-macro-transformer
   (lambda (exp rename compare)
     (let ((func (cadr exp))
           (result (rename 'result))
           (new-yield-to (rename 'new-yield-to)))
       `(let-values (((,result ,new-yield-to) (,func yield-to)))
          (set! yield-to ,new-yield-to)
          ,result)))))

(define-syntax define-coro
  (er-macro-transformer
   (lambda (exp rename compare)
     (let ((name (caadr exp))
           (args (map (lambda (n) `(define ,n '())) (cdadr exp)))
           (body (cddr exp)))
       `(define (,name yield-to)
          ,@args
          (values (begin ,@body) yield-to))))))

(define ((ask-for-data test extract) yield-to)
  (call/cc (lambda (back-here)
             (yield-to (list (make-request test extract back-here))))))

(define-coro (echo text)
  (say "Enter text for echo")
  (define text (await (ask-for-data (is-msg-class? "text") msg-data)))
  (say text))

(define-coro ((unknown-command cmd))
  (say (string-append "Unknown command: " cmd)))

(define-coro (addition x y)
  (say "x?")
  (define x (await (ask-for-data (is-msg-class? "number") (o string->number msg-data))))
  (say "y?")
  (define y (await (ask-for-data (is-msg-class? "number") (o string->number msg-data))))
  (say (string-append "Result: " (number->string (+ x y)))))

(define-coro (yes-or-no)
  (await (ask-for-data
          (lambda (msg)
            (and (is-msg-class? "text")
                 (let ((t (msg-data msg)))
                   (or (string-ci=? t "y")
                       (string-ci=? t "n")))))
          (lambda (msg)
            (string-ci=? (msg-data msg) "y")))))

(define-coro ((grow v) change)
  (say (string-append "Current value is " (number->string v)))
  (say "Change how much?")
  (define change (await (ask-for-data (is-msg-class? "number") (o string->number msg-data))))
  (if (and (> 0 change) (< v (- change)))
      (begin
        (say "It won't go negative! Are you sure?")
        (when (await yes-or-no)
          (set! v (+ v change))
          (say (string-append "Ok, it's now " (number->string v) ". It's your fault!"))))
      (set! v (+ v change)))
  (when (< 0 v)
    (say (string-append "Value is now " (number->string v)))
    (say "Continue?")
    (if (await yes-or-no)
        (await (grow v))
        (say "Ok, bye!"))))

(define queue (make-queue))
(define make-request list)
(define queue-item-test car)
(define queue-item-extract cadr)
(define queue-item-return caddr)

(define actions (make-queue))
(define (queue-action action)
  (queue-add! actions action))

(define (say msg)
  (queue-action (lambda ()
                  (print msg))))

(define (remove-one matches? list)
  (cond ((null? list) (values 'no-match '()))
        ((matches? (car list)) (values (car list) (cdr list)))
        (else (let-values (((matched filtered) (remove-one matches? (cdr list))))
                (values matched (cons (car list) filtered))))))

(define ((yield ret) requests)
  (for-each (lambda (request)
              (queue-add! queue request))
            requests)
  (ret '()))

(define (handle-command msg)
  (let ((command (msg-cmd msg)))
    (let ((func (cond
                 ((string=? "echo" command) echo)
                 ((string=? "add" command) addition)
                 ((string=? "grow" command) (grow 1))
                 (else (unknown-command command)))))
      (call/cc (lambda (here)
                 (func (yield here)))))))

(define (handle-message-or-event msg)
  (let-values (((matched filtered) (remove-one
                                    (lambda (item)
                                      ((queue-item-test item) msg))
                                    (queue->list queue))))
    (set! queue (list->queue filtered))
    (if (eq? matched 'no-match)
        (say "dont-understand")
        (call/cc (lambda (handler)
                   ((queue-item-return matched)
                    ((queue-item-extract matched) msg)
                    (yield handler)))))))

(define (main)
  (let ((queued (queue->list actions)))
    (set! actions (make-queue))
    (for-each (lambda (a) (a)) queued))
  (let ((msg (get-message)))
    (if (string=? (msg-type msg) "command")
        (handle-command msg)
        (handle-message-or-event msg))))

(define (loop)
  (main)
  (loop))

(define get-message read)