smalltalk-tng
view experiments/traits/traits.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | 5e983108e49a |
| children |
line source
1 ;; 13 April 2006, 0700 - 0840
3 (require (lib "match.ss")
4 (lib "1.ss" "srfi")
5 (lib "9.ss" "srfi"))
7 (print-struct #t)
8 (define previous-inspector (current-inspector))
9 (current-inspector (make-inspector))
11 (define-record-type <trait>
12 (make-trait operator operands)
13 trait?
14 (operator trait-operator)
15 (operands trait-operands))
17 (current-inspector previous-inspector)
19 (define (simple-trait patterns search-proc)
20 (make-trait 'simple (list patterns search-proc)))
22 (define (sum-trait traits)
23 (make-trait 'sum traits))
25 (define (override-trait traits-in-derived-to-base-order)
26 (make-trait 'override traits-in-derived-to-base-order))
28 (define (rename-trait t mapping mapping-proc)
29 (make-trait 'rename (list t mapping mapping-proc)))
31 (define (subtract-trait t patterns search-proc)
32 (make-trait 'subtract (list t patterns search-proc)))
34 (define-syntax trait*
35 (syntax-rules (+ / @ - =)
36 ((_ (+ t ...)) (sum-trait (list (trait* t) ...)))
37 ((_ (/ t ...)) (override-trait (list (trait* t) ...)))
38 ((_ (@ t (new old) ...)) (rename-trait (trait* t)
39 '((new old) ...)
40 (lambda (self-and-args)
41 (match self-and-args
42 (new (list . old)) ...
43 (_ self-and-args)))))
44 ((_ (- t pattern ...)) (subtract-trait (trait* t)
45 '(pattern ...)
46 (lambda (self-and-args)
47 (match self-and-args
48 (pattern #t) ...
49 (_ #f)))))
50 ((_ (= expr)) expr)
51 ((_ ((pattern body ...) ...)) (simple-trait '(pattern ...)
52 (lambda (self-and-args)
53 (match self-and-args
54 (pattern (lambda () body ...))
55 ...
56 (_ #f)))))
57 ((_ var) var)))
59 (define-syntax define-trait
60 (syntax-rules ()
61 ((_ name traitbody) (define name (trait* traitbody)))))
63 (define (search-trait trait self-and-args)
64 (let walk ((trait trait))
65 (let ((operands (trait-operands trait)))
66 (case (trait-operator trait)
67 ((simple) ((cadr operands) self-and-args))
68 ((sum) (let ((candidates (filter-map walk operands)))
69 (cond
70 ((null? candidates) #f)
71 ((pair? (cdr candidates)) 'conflict)
72 (else (car candidates)))))
73 ((override) (let loop ((operands operands))
74 (cond
75 ((null? operands) #f)
76 ((walk (car operands)))
77 (else (loop (cdr operands))))))
78 ((rename) (let ((new-self-and-args ((caddr operands) self-and-args)))
79 (search-trait (car operands) new-self-and-args)))
80 ((subtract) (if ((caddr operands) self-and-args)
81 #f
82 (walk (car operands))))
83 (else (error "Bad trait operator" (trait-operator trait)))))))
85 (define (make-instance trait)
86 (letrec ((self (lambda args
87 (if (null? args)
88 trait
89 (let* ((self-and-args (cons self args))
90 (method (search-trait trait self-and-args)))
91 (cond
92 ((procedure? method) (method))
93 ((not method) (error "Does not understand" args self trait))
94 ((eq? method 'conflict) (error "Method conflict" args self trait))
95 (else (error "Unknown search-trait result" method args self trait))))))))
96 self))
98 (define (instance-trait instance)
99 (instance))
101 (define (lookup-method instance . args)
102 (let* ((trait (instance-trait instance))
103 (method (search-trait trait (cons instance args))))
104 (and (procedure? method)
105 method)))
107 (define (extend base trait)
108 (make-instance (trait* (/ (= trait)
109 (= (instance-trait base))))))
111 (define-trait <extendable>
112 (((self 'extend t) (extend (self 'species) t))))
114 (define-trait <sequenceable>
115 (((self 'map f) (self 'cons (f (self 'first)) ((self 'rest) 'map f)))
116 ((self 'foldl f 'with seed) ((self 'rest) 'foldl f 'with (f (self 'first) seed)))
117 ((self 'foldr f 'with seed) (f (self 'first) ((self 'rest) 'foldr f 'with seed)))))
119 (define-trait <consable>
120 (((self 'cons f r) (self 'extend (trait* (((self 'first) f)
121 ((self 'rest) r)))))))
123 (define-trait <empty-sequenceable>
124 (((self 'map f) self)
125 ((self 'foldl f 'with seed) seed)
126 ((self 'foldr f 'with seed) seed)))
128 (define-syntax define-prototype
129 (syntax-rules ()
130 ((_ n traitbody) (define n (make-instance (trait* (/ (((self 'species) n)
131 ((self 'name) 'n))
132 traitbody)))))))
134 (define-prototype <nil> <empty-sequenceable>)
135 (define-prototype <pair> (+ <sequenceable> <consable> <extendable>))
137 (define (kons f r)
138 (<pair> 'cons f r))
140 (define (liszt . l)
141 (fold-right kons <nil> l))