1 | ;;;; coops-utils test -*- Scheme -*- |
---|
2 | ;;;; Kon Lovett, Jul '18 |
---|
3 | |
---|
4 | (import test) |
---|
5 | |
---|
6 | (import |
---|
7 | (chicken syntax) |
---|
8 | (srfi 1) |
---|
9 | (srfi 13) |
---|
10 | coops) |
---|
11 | |
---|
12 | ;;; |
---|
13 | |
---|
14 | (test-begin "Coops Utils") |
---|
15 | |
---|
16 | (import coops-utils) |
---|
17 | |
---|
18 | ; |
---|
19 | |
---|
20 | (test-assert (class? <standard-class>)) |
---|
21 | |
---|
22 | (test-assert (class? <standard-object>)) |
---|
23 | |
---|
24 | ;; setup test reference environment |
---|
25 | |
---|
26 | (define-class <s1xy> () ((x 's1xy-x) (y 's1xy-y))) |
---|
27 | (define-class <s1ab> () ((a 's1ab-a) (b 's1ab-b))) |
---|
28 | (define-class <s2xz> () ((x 's2xz-x) (z 's2xz-z))) |
---|
29 | (define-class <s2ac> () ((a 's2ac-a) (c 's2ac-c))) |
---|
30 | |
---|
31 | (define-class <s1xys1ab> (<s1xy> <s1ab>) |
---|
32 | ((x 's1xys1ab-x) (y 's1xys1ab-y) (a 's1xys1ab-a) (b 's1xys1ab-b) (me '<s1xys1ab>))) |
---|
33 | (define-class <s2xzs2ac> (<s2xz> <s2ac>) |
---|
34 | ((x 's2xzs2ac-x) (z 's2xzs2ac-z) (a 's2xzs2ac-a) (c 's2xzs2ac-c))) |
---|
35 | |
---|
36 | (define-class <s1xys2xz> (<s1xy> <s2xz>) ()) |
---|
37 | (define-class <s2xzs1ab> (<s2xz> <s1ab>) ()) |
---|
38 | |
---|
39 | (define-generic (foo abc xyz)) |
---|
40 | |
---|
41 | (define-method (foo primary: (abc <s1xy>) (xyz <s1ab>)) 'primary-<s1xy><s1ab>) |
---|
42 | (define-method (foo before: (abc <s1xy>) (xyz <s1ab>)) 'before-<s1xy><s1ab>) |
---|
43 | (define-method (foo after: (abc <s1xy>) (xyz <s1ab>)) 'after-<s1xy><s1ab>) |
---|
44 | (define-method (foo around: (abc <s1xy>) (xyz <s1ab>)) 'around-<s1xy><s1ab>) |
---|
45 | |
---|
46 | (define-method (foo primary: (abc <s2xz>) (xyz <s2ac>)) 'primary-<s2xz><s2ac>) |
---|
47 | (define-method (foo before: (abc <s2xz>) (xyz <s2ac>)) 'before-<s2xz><s2ac>) |
---|
48 | (define-method (foo after: (abc <s2xz>) (xyz <s2ac>)) 'after-<s2xz><s2ac>) |
---|
49 | (define-method (foo around: (abc <s2xz>) (xyz <s2ac>)) 'around-<s2xz><s2ac>) |
---|
50 | |
---|
51 | (test (list <s2xz> <standard-object> <s1ab>) (class-precedence-list <s2xzs1ab>)) |
---|
52 | (test '(x z a b) (class-slots <s2xzs1ab>)) |
---|
53 | |
---|
54 | (test-assert (class? <s2xzs2ac>)) |
---|
55 | (test (list <standard-object>) (class-direct-supers <s2ac>)) |
---|
56 | (test '(a c) (class-direct-slots <s2ac>)) |
---|
57 | |
---|
58 | (test-assert (class? <s1xys1ab>)) |
---|
59 | (test (list <s1xy> <s1ab>) (class-direct-supers <s1xys1ab>)) |
---|
60 | (test '(me) (class-direct-slots <s1xys1ab>)) |
---|
61 | |
---|
62 | (test 'foo (generic-name foo)) |
---|
63 | (test '(abc xyz) (generic-specialized-arguments foo)) |
---|
64 | (test-assert (eq? 2 (length (generic-primary-methods foo)))) |
---|
65 | (let ((primaries (generic-primary-methods foo))) |
---|
66 | (for-each |
---|
67 | (lambda (x) |
---|
68 | (test-assert (method? x)) |
---|
69 | (test-assert (procedure? (method-procedure x))) |
---|
70 | (let ((specials (method-specializers x))) |
---|
71 | (test-assert (list? specials)) |
---|
72 | (test-assert (every class? specials)) ) ) |
---|
73 | primaries) ) |
---|
74 | |
---|
75 | (define s1xy-inst (make <s1xy> 'x 1 'y 2)) |
---|
76 | (test-assert (instance? s1xy-inst)) |
---|
77 | (test-assert (instance-of? s1xy-inst <s1xy>)) |
---|
78 | ;(describe-object s1xy-inst) |
---|
79 | |
---|
80 | (define-class <first> () (next)) |
---|
81 | (define-class <second> (<first>) ()) |
---|
82 | (define-class <third> (<second>) ()) |
---|
83 | |
---|
84 | (define 1st (make <first> 'next (make <second> 'next (make <third> 'next "the end")))) |
---|
85 | |
---|
86 | (test "the end" (slot@ 1st next next next)) |
---|
87 | (slot@ 1st next next next = "still the end") |
---|
88 | (test "still the end" (slot@ 1st next next next)) |
---|
89 | |
---|
90 | ;make-copy |
---|
91 | (let ((inst (make-copy s1xy-inst 'y 23))) |
---|
92 | (test "make-copy" 23 (slot@ inst y)) ) |
---|
93 | |
---|
94 | (let () |
---|
95 | (define-generic (city-market-class obj)) |
---|
96 | (define-generic (city-goods obj)) |
---|
97 | (define-class city () (name (market-class reader: city-market-class) sellers buyers (goods accessor: city-goods))) |
---|
98 | (define temphawa (make city 'name "Hawa" 'market-class 2)) |
---|
99 | (test-assert "make-copy temphawa" (make-copy temphawa)) ) |
---|
100 | |
---|
101 | ;primitive-instance? |
---|
102 | |
---|
103 | ;--- |
---|
104 | #| |
---|
105 | ;; Named (has a name) "concept" |
---|
106 | |
---|
107 | (define-generic (name obj)) |
---|
108 | (define-class <named> () ( |
---|
109 | (namsym #:reader name) ) ) |
---|
110 | |
---|
111 | ;; Moves foreward thru a set of values "concept" |
---|
112 | |
---|
113 | (define-generic (step-function obj)) |
---|
114 | (define-class <stepper> () ( |
---|
115 | (nxtval #:reader step-function) ) ) |
---|
116 | (define-generic (next-value obj)) |
---|
117 | (define-method (next-value (obj <stepper>)) ((step-function obj))) |
---|
118 | |
---|
119 | ;; Parameterized extension "concept" |
---|
120 | |
---|
121 | (define-generic (parameters obj)) |
---|
122 | (define-generic (basis obj)) |
---|
123 | (define-class <parameterized> () ( |
---|
124 | (parms #:reader parameters) |
---|
125 | (src #:reader basis) ) ) |
---|
126 | |
---|
127 | ;; Parameterized generative set of random values "concept" |
---|
128 | |
---|
129 | (define-class <random-distribution> (<named> <parameterized> <stepper>) ( |
---|
130 | temp ) ) |
---|
131 | |
---|
132 | ;; Create an instance of <random-distribution> where the arguments are |
---|
133 | ;; the same as the documented procedural distribution API. |
---|
134 | ;; |
---|
135 | ;; SRFI 27 API: ({some distribution constructor} arg...) |
---|
136 | ;; OO API: (make-random-distribution {some distribution constructor} arg...) |
---|
137 | |
---|
138 | (define-syntax make-random-distribution |
---|
139 | (syntax-rules () |
---|
140 | ((_ ?ctor ?arg0 ...) |
---|
141 | (make <random-distribution> 'temp (?ctor ?arg0 ...)) ) ) ) |
---|
142 | |
---|
143 | (define-method (initialize-instance (obj <random-distribution>)) |
---|
144 | ;Reconstruct distribution api ctor invocation parameters |
---|
145 | ;(The 'ctor' must be a globally defined procedure compiled |
---|
146 | ;with procedure-information. So if following nomenclature then the last |
---|
147 | ;procedure name element will be the kind of distribution.) |
---|
148 | (let* ( |
---|
149 | (temp (slot@ obj temp)) |
---|
150 | (ctor (car temp)) |
---|
151 | (procinfo (procedure-information ctor)) |
---|
152 | (name (and (pair? procinfo) (symbol->string (car procinfo)))) |
---|
153 | (name |
---|
154 | (and-let* ( |
---|
155 | (name) |
---|
156 | (kndpos (string-index-right name #\-))) |
---|
157 | (substring/shared name (+ kndpos 1)) ) ) |
---|
158 | (dstr-vals (receive (apply ctor (cdr temp)))) |
---|
159 | (parms (and (<= 2 (length dstr-vals)) (receive ((second dstr-vals))))) ) |
---|
160 | (slot@ obj temp = #f) ;"free" the "any" slot |
---|
161 | (slot@ obj namsym = (string->symbol name)) |
---|
162 | (slot@ obj nxtval = (first dstr-vals)) |
---|
163 | (slot@ obj parms = (and parms (drop-right parms 1))) ) ) |
---|
164 | |# |
---|
165 | |
---|
166 | ; |
---|
167 | |
---|
168 | (test-end "Coops Utils") |
---|
169 | |
---|
170 | ;; |
---|
171 | |
---|
172 | (import coops-describe) |
---|
173 | |
---|
174 | (test-group "Coops Describe" |
---|
175 | (describe-object <third>) |
---|
176 | (newline) |
---|
177 | (describe-object s1xy-inst) |
---|
178 | (newline) |
---|
179 | (describe-object describe-object) |
---|
180 | (newline) |
---|
181 | (print-closure describe-object) |
---|
182 | ) |
---|
183 | |
---|
184 | ;; |
---|
185 | |
---|
186 | (import coops-introspection) |
---|
187 | |
---|
188 | (test-begin "Coops Introspection") |
---|
189 | |
---|
190 | (generic-name describe-object) |
---|
191 | |
---|
192 | (test-end "Coops Introspection") |
---|
193 | |
---|
194 | ;;; |
---|
195 | |
---|
196 | (test-exit) |
---|