blob: 701c45c0fd8a178170f32da2a7344c6538d870bb (
plain)
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
|
(define-module (test object)
:use-module (srfi srfi-64)
:use-module (srfi srfi-64 test-error)
:use-module (srfi srfi-88)
:use-module (hnh util object)
:use-module ((hnh util) :select (->)))
(define-type (f) x)
(test-group "Created procedures"
(test-assert "Constructor" (procedure? f))
(test-assert "Predicate" (procedure? f?))
(test-assert "Field access" (procedure? x)))
;; (f)
;; (f x: 10)
;; (f? (f))
(test-equal "Accessors are getters"
10 (x (f x: 10)))
(test-assert "Accessors update, returning a object of the original type"
(f? (x (f x: 10) 20)))
(test-equal "A get after an update returns the new value"
20 (-> (f x: 10)
(x 20)
x))
(define-type (g) x)
(test-assert "Second type can be created"
(g x: 10))
(test-assert "Second type isn't first type"
(not (f? (g x: 10))))
(test-assert "First type isn't second type"
(not (g? (f x: 10))))
;; Tests that the old x gets shadowed
;; (test-equal 10 (x (f x: 10)))
;; (test-equal 10 (x (g x: 10)))
;; field-level arguments
;; - init:
(define-type (f2) (f2-x default: 0 type: integer?))
(test-equal 0 (f2-x (f2)))
;; - type:
(test-error "Giving an invalid type to the constructor throws an error"
'wrong-type-arg (f2 f2-x: 'hello))
(test-error "Giving an invalid type to a setter throws an error"
'wrong-type-arg (f2-x (f2) 'hello))
(test-equal "The error includes the name of the field, the expected type, and the given value"
'(f2-x integer? hello)
(catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello))
(lambda (err proc fmt args data) args)))
(test-equal "Typed setter updates the value"
(f2 f2-x: 10) (f2-x (f2) 10))
;; type-level arguments
;; - constructor:
(define-type (f3 constructor: (lambda (make check)
(lambda* (#:key f3-x f3-y)
(check f3-x f3-y)
(make f3-x f3-y))))
(f3-x type: integer?)
(f3-y type: string?))
(test-assert "Custom constructors create objcets"
(f3? (f3 f3-x: 10 f3-y: "Hello")))
(test-error "Bad arguments to custom constructor"
'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world))
;; - printer:
(define-type (f4 printer: (lambda (r p) (display "something" p))))
(test-equal "something" (with-output-to-string (lambda () (write (f4)))))
|
