smalltalk-tng
view experiments/traits/traits2.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | 4da4336acbb8 |
| children |
line source
1 ;; 13 April 2006, 0700 - 0840
3 (require (lib "match.ss")
4 (lib "pretty.ss")
5 (lib "1.ss" "srfi")
6 (lib "9.ss" "srfi"))
8 (print-struct #t)
9 (define previous-inspector (current-inspector))
10 (current-inspector (make-inspector))
12 (define-record-type <trait>
13 (make-trait operator operands)
14 trait?
15 (operator trait-operator)
16 (operands trait-operands))
18 (current-inspector previous-inspector)
20 (define (simple-trait patterns search-proc)
21 (make-trait 'simple (list patterns search-proc)))
23 (define (sum-trait traits)
24 (make-trait 'sum traits))
26 (define (override-trait traits-in-derived-to-base-order)
27 (make-trait 'override traits-in-derived-to-base-order))
29 (define (rename-trait t mapping mapping-proc)
30 (make-trait 'rename (list t mapping mapping-proc)))
32 (define (subtract-trait t patterns search-proc)
33 (make-trait 'subtract (list t patterns search-proc)))
35 (define-syntax trait*
36 (syntax-rules (+ / @ - = ^)
37 ((_ (+ t ...)) (sum-trait (list (trait-expr t) ...)))
38 ((_ (/ t ...)) (override-trait (list (trait-expr t) ...)))
39 ((_ (@ t (new old) ...)) (rename-trait (trait-expr t)
40 '((new old) ...)
41 (lambda (self-and-args)
42 (match self-and-args
43 (new (list . old)) ...
44 (_ self-and-args)))))
45 ((_ (- t pattern ...)) (subtract-trait (trait-expr t)
46 '(pattern ...)
47 (lambda (self-and-args)
48 (match self-and-args
49 (pattern #t) ...
50 (_ #f)))))
51 ((_ (= expr)) expr)
52 ((_ (^ pattern body ...)) (trait* (((self . pattern) body ...))))
53 ((_ ((pattern body ...) ...)) (simple-trait '(pattern ...)
54 (lambda (self-and-args)
55 (match self-and-args
56 (pattern (lambda () (trait-expr body) ...))
57 ...
58 (_ #f)))))
59 ((_ var) var)))
61 (define-syntax trait-expr
62 (syntax-rules (quote let if)
63 ((_ #(item ...))
64 (trait* (item ...)))
66 ((_ (quote v))
67 (quote v))
69 ((_ (let ((pattern expr) ...) body ...))
70 (trait-expr (let dummy ((pattern expr) ...) body ...)))
72 ((_ (let loop ((pattern expr) ...) body ...))
73 (trait-expr (#(((loop pattern ...) body ...))
74 expr ...)))
76 ((_ (receiver arg ...))
77 (traits-send (trait-expr receiver) (list (trait-expr arg) ...)))
79 ((_ other)
80 other)))
82 (define-syntax define-trait
83 (syntax-rules ()
84 ((_ name traitbody) (define name (trait-expr traitbody)))))
86 (define (search-trait trait self-and-args)
87 (let walk ((trait trait))
88 (let ((operands (trait-operands trait)))
89 (case (trait-operator trait)
90 ((simple) ((cadr operands) self-and-args))
91 ((sum) (let ((candidates (filter-map walk operands)))
92 (cond
93 ((null? candidates) #f)
94 ((pair? (cdr candidates)) 'conflict)
95 (else (car candidates)))))
96 ((override) (let loop ((operands operands))
97 (cond
98 ((null? operands) #f)
99 ((walk (car operands)))
100 (else (loop (cdr operands))))))
101 ((rename) (let ((new-self-and-args ((caddr operands) self-and-args)))
102 (search-trait (car operands) new-self-and-args)))
103 ((subtract) (if ((caddr operands) self-and-args)
104 #f
105 (walk (car operands))))
106 (else (error "Bad trait operator" (trait-operator trait)))))))
108 (define (traits-for o)
109 (cond
110 ((trait? o) o)
111 ((number? o) <number>)
112 ((string? o) <string>)
113 ((symbol? o) <symbol>)
114 ((boolean? o) <boolean>)
115 ((pair? o) <scheme-pair>)
116 ((null? o) <nil>)
117 ((procedure? o) (simple-trait '(any) (lambda (self-and-args) (lambda () (apply o (cdr self-and-args))))))))
119 (define (invoke-method traits self args)
120 (let ((method (search-trait traits (cons self args))))
121 (cond
122 ((procedure? method) (method))
123 ((not method) (error "Does not understand" args self))
124 ((eq? method 'conflict) (error "Method conflict" args self))
125 (else (error "Unknown search-trait result" method args self)))))
127 (define (lookup-method self args)
128 (let ((method (search-trait self (cons self args))))
129 (and (procedure? method)
130 method)))
132 (define (traits-send o args)
133 (invoke-method (traits-for o) o args))
135 (define-trait <extendable>
136 #(((self 'extend-with trait) #(/ trait (self 'species)))))
138 (define-trait <sequenceable>
139 #(((self 'map f) (self 'cons (f (self 'first)) ((self 'rest) 'map f)))
140 ((self 'foldl f 'with seed) ((self 'rest) 'foldl f 'with (f (self 'first) seed)))
141 ((self 'foldr f 'with seed) (f (self 'first) ((self 'rest) 'foldr f 'with seed)))))
143 (define-trait <consable>
144 #(((self 'cons f r) (self 'extend-with #(((self 'first) f)
145 ((self 'rest) r)
146 ((self 'empty?) #f))))))
148 (define-trait <empty-sequenceable>
149 #(((self 'map f) self)
150 ((self 'foldl f 'with seed) seed)
151 ((self 'foldr f 'with seed) seed)
152 ((self 'empty?) #t)))
154 (define-trait <boolean>
155 #(((self 'ifTrue t) #(= (if self (trait-expr (t)) #f)))
156 ((self 'ifFalse f) #(= (if self #f (trait-expr (f)))))
157 ((self 'ifTrue t 'ifFalse f) #(= (if self (trait-expr (t)) (trait-expr (f)))))))
159 (define tmap (trait-expr #(((self f seq)
160 ((seq 'empty?)
161 'ifTrue #(^() seq)
162 'ifFalse #(^() (seq 'cons (f (seq 'first)) (self f (seq 'rest)))))))))
164 (define-syntax define-prototype
165 (syntax-rules ()
166 ((_ n traitbody) (define n (trait-expr #(/ #(((self 'species) n)
167 ((self 'name) 'n))
168 traitbody))))))
170 (define-prototype <nil> <empty-sequenceable>)
171 (define-prototype <pair> #(+ <sequenceable> <consable> <extendable>))
173 (define-prototype <scheme-pair> (<pair> 'extend-with #(((self 'first) #(= (car self)))
174 ((self 'rest) #(= (cdr self)))
175 ((self 'empty?) #f)
176 ((self 'cons f r) #(= (cons f r))))))
178 (define (kons f r)
179 (trait-expr (<pair> 'cons f r)))
181 (define (liszt . l)
182 (fold-right kons <nil> l))
184 (define (expand-series exp)
185 (pretty-print exp)(newline)
186 (let loop ((stx (expand-once exp)))
187 (pretty-print (syntax-object->datum stx))(newline)
188 (let ((next (expand-once stx)))
189 (when (not (equal? (syntax-object->datum stx)
190 (syntax-object->datum next)))
191 (loop next)))))