~bjoli/awesome-coroutine-generators

awesome-coroutine-generators/awesome-coroutine-generators/base.scm -rw-r--r-- 3.5 KiB
32e16c30 — Linus Fix readme. 1 year, 9 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
;; I, Linus Björnstam, release this into the public domain.
;; If public domain is not applicable in your jurisdiction
;; you may use this under the Creative Commons 0 licence.
;; I hope you have fun, though.

(define-module (awesome-coroutine-generators base)
  #:use-module (ice-9 receive)
  #:use-module (srfi  srfi-9)
  #:replace (yield) ;; why is this necessary? shouldn't yield be in ice-9 threads?
  #:export (generator-end?
            generator-end-values
            yield
            yield-from
            current-yielder
            %tag

            maybe-none

            none?

            make-generator
            make-simple-generator
            generator
            simple-generator))

(define-record-type <generator-end>
  (make-generator-end end-values)
  generator-end?
  (end-values generator-end-values))

(define-record-type <none>
  (make-none) %none?)

;; the none value is not exported
(define the-none (make-none))
(define (none? x)
  (eq? x the-none))

(define %tag (make-prompt-tag))

(define current-yielder
  (make-parameter (lambda vals (apply abort-to-prompt %tag vals))))

(define (%yield . args)
  (apply (current-yielder) args))

(define-syntax-parameter yield
  (lambda (stx)
    (syntax-violation 'yield "Yield used outside of a generator" stx)))

(define (make-generator proc)
  (define (run . args)
    (receive vals (apply proc args)
      (if (none? (car vals))
          (make-generator-end '())
          (make-generator-end vals))))
  (lambda args
    (call-with-prompt %tag
      (lambda () (apply run args))
      (lambda (k . ret)
        (set! run k)
        (apply values ret)))))

(define (make-simple-generator proc)
  (define (run)
    (proc)
    (make-generator-end (if #f #f)))
  (lambda ()
    (call-with-prompt %tag
      run
      (lambda (k ret)
        (set! run k)
        ret))))
  
(define-syntax generator
  (syntax-rules ()
    ((_ formals body body* ...)
     (let ((run (lambda formals
                  (receive ret-vals
                      (syntax-parameterize ((yield (syntax-rules ()
                                                     ((yield vals (... ...)) (%yield vals (... ...))))))
                        (let ()
                          body body* ...))
                    (if (or (null? ret-vals) (none? (car ret-vals)))
                        (make-generator-end '())
                        (make-generator-end ret-vals))))))
       (lambda args
         (call-with-prompt %tag
           (lambda () (apply run args))
           (lambda (k . ret)
             (set! run k)
             (apply values ret))))))))

(define-syntax simple-generator
  (syntax-rules ()
    ((_ body body* ...)
     (let ((run (lambda () body body* ... (make-generator-end (if #f #f)))))
       (lambda ()
         (call-with-prompt %tag
           run
           (lambda (k val)
             (set! run k)
             val)))))))

(define-syntax maybe-none
  (syntax-rules ()
    ((_ expr)
     (maybe-none 1 expr))
    ((_ no expr)
     (receive vals expr
       (if (pair? vals)
           (apply values vals)
           (apply values (map (lambda (x) the-none) (iota no))))))))

;; In a perfect world, I would be intelligent enough to write this
;; in an efficient way.
(define (yield-from g)
  (define (int . vals)
    (cond ((and (pair? vals) (generator-end? (car vals)))
           (car vals))
          (else
           (receive vals2 (apply %yield vals)
             (receive vals3 (apply g vals2)
               (apply int vals3))))))

  (call-with-values int g))