~subsetpark/fugue

ref: e28cd6b81fb1803951ee20eb4da944ab88d0f99f fugue/test/fugue.janet -rw-r--r-- 14.5 KiB
e28cd6b8 — Zach Smith fold registry back in 2 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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
(use testament)
(import /fugue)

(def tab @{})

(deftest table-not-a-proto
  (is (not (fugue/prototype? tab))))

(defn- proto-tests [proto]
  (is (fugue/prototype? proto))
  (is (fugue/Root? proto))
  (is (fugue/Root*? proto))
  (is (= fugue/Root (table/getproto proto))))

(defmacro- inst-tests [proto inst]
  (upscope
    @[~(is ,(symbol proto "?") ,inst)
      ~(is ,(symbol proto "*?") ,inst)
      ~(is (not (fugue/prototype? ,inst)))
      ~(is (= ,proto (table/getproto ,inst)))]))

(defmacro- accessor-tests [accessor objs &opt refute]
  ~(each obj ,objs (is (,(if refute not= =) (,accessor obj) (obj ,(keyword accessor))))))

(fugue/defproto Animal ())

(deftest base-defproto
  (proto-tests Animal)
  (let [an-animal (:new Animal)]
    (inst-tests Animal an-animal)))

(deftest constructor
  (let [cat (:new Animal :name "Bowler Cat")]
    (inst-tests Animal cat)
    (is (= "Bowler Cat" (cat :name)))))

(deftest new-form
  (let [an-animal (new-Animal)]
    (inst-tests Animal an-animal)))

(fugue/defproto Human () name {:default "John Doe"})

(deftest defaults
  (proto-tests Human)
  (let [a-human (:new Human)]
    (inst-tests Human a-human)
    # The default value has been set on the instance
    (is (= "John Doe" (a-human :name)))
    # But it's not on the Prototype.
    (is (nil? (Human :name)))
    (accessor-tests name [a-human Human])))

(fugue/defproto Light () speed {:default math/inf})

(deftest symbol-defaults
  (proto-tests Light)
  (let [a-light (:new Light)]
    (inst-tests Light a-light)
    (is (number? (a-light :speed)))))

(fugue/defproto Stack () data {})
(fugue/defmethod _init Stack [self] (put self :data @[]))

(deftest mutable-default-fns
  (let [a-stack (:new Stack)
        b-stack (:new Stack)]
    (array/push (a-stack :data) :ok)
    (is (empty? (b-stack :data)))))

(fugue/defproto SharingStack () data {:default @[]})

(deftest mutable-defaults
  (let [a-stack (:new SharingStack)
        b-stack (:new SharingStack)]
    (array/push (a-stack :data) :ok)
    (is (== @[:ok] (b-stack :data)))))

(def inner-stack @[])
(fugue/defproto DeepStack () data {})
(fugue/defmethod _init DeepStack [self] (put self :data @[inner-stack]))

(deftest inner-references-are-not-copied
  (let [a-stack (:new DeepStack)
        b-stack (:new DeepStack)]
    (put-in a-stack [:data 0 0] :ok)
    (is (== @[@[:ok]] (b-stack :data)))))

(fugue/defproto Container () capacity {:init? true})

(deftest init
  (proto-tests Container)
  (is (thrown? (:new Container)))
  (let [a-container (:new Container 500)]
    (inst-tests Container a-container)
    (is (= 500 (a-container :capacity)))
    (accessor-tests capacity [a-container Container])))

(fugue/defproto Concat () left {:init? true} right {:init? true})

(deftest multi-inits
  (is (thrown? (:new Concat "left"))))

(fugue/defproto Citizen () president {:allocation :prototype})

(deftest allocation
  (proto-tests Citizen)
  (let [a-citizen (:new Citizen)
        another-citizen (:new Citizen)]
    (inst-tests Citizen a-citizen)
    (fugue/allocate a-citizen :president "The Next Guy")
    # Allocating a field on one instance sets the value on the
    # prototype, and thus is inherited by all instances.
    (is (= "The Next Guy" (Citizen :president)))
    (is (= "The Next Guy" (another-citizen :president)))
    (accessor-tests president [a-citizen another-citizen Citizen])))

(fugue/defproto Editor () mode {:allocate-value "vi"})
(fugue/defproto Light () speed {:allocate-value math/inf})

(deftest allocate-value
  (proto-tests Editor)
  (let [an-editor (:new Editor)
        another-editor (:new Editor)
        some-light (:new Light)]
    (inst-tests Editor an-editor)
    (fugue/allocate an-editor :mode "emacs")
    # The prototype has been allocated a value for `:mode`, which is
    # inherited; but allocating a new value to an instance shadows, it
    # doesn't overwrite.
    (is (= "vi" (Editor :mode)))
    (is (= "vi" (another-editor :mode)))
    (is (= "emacs" (an-editor :mode)))
    (accessor-tests mode [an-editor another-editor Editor])
    (is (= :number (type (some-light :speed))))
    (is (> (some-light :speed) 0))))

(fugue/defproto Dog ()
                name {:allocate-value "Fido"}
                collar-color {:default "blue"})
(fugue/defproto Pekingese Dog
                size {:default "Extremely Small"})

(deftest inheritance
  (is (= Dog (table/getproto Pekingese)))

  (let [a-pekingese (:new Pekingese)]

    (inst-tests Pekingese a-pekingese)
    (accessor-tests name [a-pekingese Dog Pekingese])
    (accessor-tests size [a-pekingese Pekingese])

    (is (thrown? (size Dog)))
    (is (= "Fido" (name a-pekingese)))
    (is (= "Fido" (a-pekingese (fugue/@ Pekingese :name))))

    (is (= "Extremely Small" (size a-pekingese)))

    (is (Pekingese? a-pekingese))

    (is (Dog? Pekingese))
    (is (not (Dog? a-pekingese)))

    (is (Dog*? a-pekingese))
    (is (Dog*? Pekingese))

    (is (= "blue" (collar-color a-pekingese)))
    (is (= "blue" (a-pekingese (fugue/@ Pekingese :collar-color))))))

(fugue/defproto Form () unique-field {:getter get-unique-field})

(deftest getter
  (let [a-form (:new Form :unique-field :echo)
        a-dog (:new Dog)]
    (is (nil? (dyn 'unique-field)))
    (is (= :echo (get-unique-field a-form)))
    (is (= :echo (a-form (fugue/@ Form :unique-field))))
    (is (thrown? (apply fugue/@ '[Dog :unique-field])))))

(fugue/defproto Form2 () second-unique-field {:getter false})

(deftest no-getter
  (let [a-form (:new Form :second-unique-field :echo)]
    (is (nil? (dyn 'second-unique-field)))))

(fugue/defproto Caster ())
(fugue/defmethod _init Caster [inst] (freeze inst))

(deftest after-init
  (let [casted (:new Caster)]
    (is (not (table? casted)))
    (is (struct? casted))))

(fugue/defgeneric do-nothing [_] :ok)
(fugue/defgeneric raise [_])
(fugue/defgeneric shout [x] (string x "!"))

(deftest generics
  (let [shouting-Dog (:new Dog)]
    (put shouting-Dog :shout (fn [self] (string (name self) "!")))

    (is (= :ok (do-nothing :ok)))
    (is (thrown? (raise :ok)))
    (is (= "hi!" (shout "hi")))
    (is (= "Fido!" (shout shouting-Dog)))))

(fugue/defmethod speak Dog [self] (string "My name is " (self :name)))
(fugue/defmethod speak Pekingese [self] (string (__super self) " and I am " (self :size)))

(deftest methods
  (let [a-pekingese (:new Pekingese)]
    (is (= "My name is Fido and I am Extremely Small" (speak a-pekingese)))
    (is (thrown? (speak (:new Editor))))))

(fugue/defmethod speak2 Dog [self speech] (string "Speak the speech, " speech))

(deftest n-arg methods
  (let [a-dog (:new Dog)]
    (is (= "Speak the speech, I am a dog." (speak2 a-dog "I am a dog.")))))

(fugue/defmethod eat Dog
                 [self & objects]
                 (string (self :name) " eats all of " (string/join objects ", ")))

(deftest ampersand
  (let [a-dog (:new Dog)]
    (is (= "Fido eats all of ball, shoe" (eat a-dog "ball" "shoe")))))

(fugue/defmulti add [Animal] [f] (put f :value 1))
(fugue/defmulti add [:number] [x] (+ x 1))
(fugue/defmulti add [:string] [s] (string s "!"))

(deftest multimethods
  (let [an-animal (:new Animal)]
    (add an-animal)
    (is (= 11 (add 10)))
    (is (= "s!" (add "s")))
    (is (= 1 (an-animal :value)))))

(fugue/defmulti cat [:string _] [s1 s2] (string s1 s2))
(fugue/defmulti cat [:string :number] [s n] (string s " #" n))
(fugue/defmulti cat [_ :number] [m n] (+ m n))
(fugue/defmulti cat [_ _] [x y] (string/format "Falling back to %q<>%q" x y))

(deftest multi-specialization
  # [:string :string] matches [:string :_]
  (is (= "hello world" (cat "hello " @"world")))
  # [:string :number] matches [:string :_] and [:_ :number], but
  # [:string :number] is more specific
  (is (= "hello #100" (cat "hello" 100)))
  # [:number :number] matches [:_ :number]}
  (is (= 9 (cat 4 5)))
  # [:_ :_] will never match before a more specific typing
  (is (= "Falling back to @\"x\"<>@\"y\"" (cat @"x" @"y"))))

(fugue/defmulti cat2 [_ :number] [n m] (+ n m))
(fugue/defmulti cat2 [:string _] [s s2] (string s "+" s2))

(deftest positional-specialization
  # Both [:_ :number] and [:string :_] match, but where there are
  # multiple matches, choose the typing with the more specific term in
  # the earliest position.
  (is (= "x+2" (cat2 "x" 2))))

(fugue/defproto Stack ())
(fugue/defproto Operation ())

(fugue/defmulti push [Stack _] [_ _] :fallback)
(fugue/defmulti push [Stack Operation] [_ _] :pattern-match)

(deftest proto-specialization
  (let [s (:new Stack)
        add (:new Operation)]
    (is (= :fallback (push s 5)))
    (is (= :pattern-match (push s add)))))

(fugue/defmulti to-string [:number] [n] (string "+" n))
(do
  (fugue/defmulti to-string [:string] [s] (string s "!")))

(fugue/declare-open-multi to-string2)
(do
  (fugue/extend-multi to-string2 [:number] [n] (string "+" n))
  (fugue/extend-multi to-string2 [:string] [s] (string s "!")))

(deftest open-multimethods
  # normal multimethods obey scoping rules; a scoped def is not
  # available in enclosing (or adjacent) environments.
  (is (= "+10" (to-string 10)))
  (is (thrown? (to-string "s")))

  # open methods can be extended from other scopes.
  (is (= "s!" (to-string2 "s")))
  (is (= "+10" (to-string2 10))))

(fugue/declare-open-multi to-string3)
(defn inner-f [] :ok)
(fugue/extend-multi to-string3 [:number] [n] (inner-f))
(defn inner-f [] :notok)
(fugue/extend-multi to-string3 [:string] [n] "trigger redefinition of to-string3")

(deftest multi-closures
  (is (= :ok (to-string3 10))))

(deftest multimethod-type-validation
  (is (thrown? (apply fugue/defmulti ['bongo ["ok"] ['x] :ok]))))

(def bare-table @{})
(def child (table/setproto @{} bare-table))
(fugue/defmulti match-on-table [bare-table] [_] :ok)

(deftest table-multimethod
  (is (= :ok (match-on-table child)))
  (is (thrown? (match-on-table @{}))))

(deftest new-root
  (let [a-root (:new fugue/Root)]
    (inst-tests fugue/Root a-root)))

(deftest defproto-in-test
  (fugue/defproto InTest ())
  (proto-tests InTest)
  (let [a-in-test (:new InTest)]
    (inst-tests InTest a-in-test)))

(deftest defproto-child-in-test
  (fugue/defproto InTestParent nil)
  (fugue/defproto InTestChild InTestParent)

  (is (InTestParent? InTestChild))
  (is (InTestChild? (new-InTestChild))))

(deftest value-in-test
  (def some-particular-name "Wonkus")
  (def some-particular-table @{})
  (fugue/defproto ValueInTest nil name {:default some-particular-name})
  (fugue/defproto MutableValueInTest nil tab {:default some-particular-table})
  (is (= "Wonkus" ((new-ValueInTest) :name)))
  (is (= some-particular-table ((new-MutableValueInTest) :tab))))

(deftest allocation-in-test
  (def some-particular-name "Wonkus")
  (def some-particular-table @{})
  (fugue/defproto ValueInTest nil name {:allocate-value some-particular-name})
  (fugue/defproto MutableValueInTest nil tab {:allocate-value some-particular-table})
  (is (= "Wonkus" (ValueInTest :name)))
  (is (= some-particular-table (MutableValueInTest :tab))))

(deftest proto-attributes
  (fugue/defproto BasicConstructor nil)
  (fugue/defproto NameConstructor nil {:constructor another-name})
  (fugue/defproto NoConstructor nil {:constructor false})

  (is (BasicConstructor? (new-BasicConstructor)))
  (is (NameConstructor? (another-name)))
  (is (nil? (dyn 'new-NoConstructor))))

(deftest defgeneric-in-test
  (fugue/defgeneric in-test [x] (string x " ok"))
  (is (= "a ok" (in-test "a"))))

(deftest defmethod-in-test
  (fugue/defproto HasMethod () name {})
  (fugue/defmethod in-test HasMethod [m] (m :name))
  (let [a-has-method (:new HasMethod :name "dobby")]
    (is (= "dobby" (in-test a-has-method)))))

(fugue/defproto ToShadowField nil name {})

(deftest defmethod-warning
  (def buffer @"")
  (with-dyns [:out buffer]
    (apply fugue/defmethod '[name ToShadowField [x] "ok"]))

  (is (==
        "Warning: you are defining a method named name on the prototype ToShadowField; there is a field of the same name on that prototype.\n"
        buffer)))

# Define generic so we get a clean stdout
(fugue/defgeneric height [x] :ok)

(deftest defmethod-warning-in-test
  (fugue/defproto ShadowInTest nil height {})

  (def buffer @"")
  (with-dyns [:out buffer]
    (apply fugue/defmethod '[height ShadowInTest [x] "ok"]))

  (is (==
        "Warning: you are defining a method named height on the prototype ShadowInTest; there is a field of the same name on that prototype.\n"
        buffer)))

(deftest defmulti-in-test
  (fugue/defmulti in-test-multi [:number] [n] (inc n))
  (is (= 2 (in-test-multi 1))))

(deftest extend-multi-in-test
  (fugue/declare-open-multi open-in-test)
  (fugue/extend-multi open-in-test [:number] [n] (inc n))
  (is (= 2 (open-in-test 1))))

(fugue/declare-open-multi open-headless)

(deftest open-defaults
  (is (thrown? (open-headless))))

(fugue/defproto SlotHaver () name {})

(deftest slots-test
  (let [a-slot-haver (:new SlotHaver)]
    (def res (fugue/with-slots SlotHaver a-slot-haver
                               (set (@ name) "will shortz")
                               (is (= "will shortz" (@ name)))
                               (is (= "will shortz" (@ :name)))
                               (is (= "will shortz" (name @)))))
    (is (= res a-slot-haver))
    (is (= "will shortz" (a-slot-haver :name)))))

(deftest slots-as-test
  (let [a-slot-haver (:new SlotHaver)]
    (def res (fugue/with-slots-as SlotHaver a-slot-haver s
                                  (set (s name) "will shortz")
                                  (is (= "will shortz" (s name)))
                                  (is (= "will shortz" (s :name)))
                                  (is (= "will shortz" (name s)))))
    (is (= res a-slot-haver))
    (is (= "will shortz" (a-slot-haver :name)))))

(deftest slots-validation
  (is (thrown? (apply fugue/with-slots '[SlotHaver {} (@ other)]))))

(deftest nested-with-slots
  (let [a-slot-haver (new-SlotHaver :name "A")
        b-slot-haver (new-SlotHaver :name "B")]
    (fugue/with-slots SlotHaver a-slot-haver
                      (fugue/with-slots-as SlotHaver b-slot-haver @@
                                           (set (@ name) "A2")
                                           (set (@@ name) "B2")))
    (is (= "A2" (a-slot-haver :name)))
    (is (= "B2" (b-slot-haver :name)))))

(deftest @-macro
  (is (= (fugue/@ SlotHaver :name) :name))
  (let [a-slot-haver (new-SlotHaver :name "Freddie")
        not-a-member-of-queen {:name "Queen Victoria"}]
    (is (= "Freddie" (a-slot-haver (fugue/@ SlotHaver :name))))
    (is (= "Freddie" (fugue/@ SlotHaver a-slot-haver :name)))
    (set (a-slot-haver (fugue/@ SlotHaver :name)) "Brian May")
    (is (= "Brian May" (a-slot-haver :name)))
    (is (thrown? (fugue/@ SlotHaver not-a-member-of-queen :name)))))

(run-tests!)