source: project/srfi-89/tests.scm @ 7231

Last change on this file since 7231 was 7231, checked in by felix winkelmann, 13 years ago

added srfi-89

File size: 4.2 KB
Line 
1(use test srfi-89)
2
3(test-begin)
4
5  (define* (f a (b #f)) (list a b))
6
7(test '(1 #f) (f 1)                  )
8(test '(1 2) (f 1 2)                )
9(test-error (f 1 2 3)              )
10
11    (define* (g a (b a) (key: k (* a b))) (list a b k))
12
13(test '(3 3 9) (g 3)                  )
14(test '(3 4 12) (g 3 4)                )
15(test-error  (g 3 4 key:)           )
16(test '(3 4 5) (g 3 4 key: 5)         )
17(test-error (g 3 4 zoo: 5)         )
18(test-error (g 3 4 key: 5 key: 6)  )
19
20    (define* (h1 a (key: k #f) . r) (list a k r))
21
22(test '(7 #f ()) (h1 7)                 )
23(test '(7 #f (8 9 10)) (h1 7 8 9 10)          )
24(test '(7 8 (9 10)) (h1 7 key: 8 9 10)     )
25(test-error (h1 7 key: 8 zoo: 9)   )
26
27    (define* (h2 (key: k #f) a . r) (list a k r))
28
29(test '(7 #f ()) (h2 7)                 )
30(test '(7 #f (8 9 10)) (h2 7 8 9 10)          )
31(test '(9 8 (10)) (h2 key: 8 9 10)       )
32(test-error (h2 key: 8 zoo: 9)     )
33
34    (define absent (list 'absent))
35
36    (define (element tag content . attributes)
37      (list "<" tag attributes ">"
38            content
39            "</" tag ">"))
40             
41    (define (attribute name value)
42      (if (eq? value absent)
43          '()
44          (list " " name "=" (escape value))))
45
46    (define (escape value) value) ; could be improved!
47             
48    (define (make-html-styler tag)
49      (lambda* ((id:          id          absent)
50                (class:       class       absent)
51                (title:       title       absent)
52                (style:       style       absent)
53                (dir:         dir         absent)
54                (lang:        lang        absent)
55                (onclick:     onclick     absent)
56                (ondblclick:  ondblclick  absent)
57                (onmousedown: onmousedown absent)
58                (onmouseup:   onmouseup   absent)
59                (onmouseover: onmouseover absent)
60                (onmousemove: onmousemove absent)
61                (onmouseout:  onmouseout  absent)
62                (onkeypress:  onkeypress  absent)
63                (onkeydown:   onkeydown   absent)
64                (onkeyup:     onkeyup     absent)
65                .
66                content)
67        (element tag
68                 content
69                 (attribute "id" id)
70                 (attribute "class" class)
71                 (attribute "title" title)
72                 (attribute "style" style)
73                 (attribute "dir" dir)
74                 (attribute "lang" lang)
75                 (attribute "onclick" onclick)
76                 (attribute "ondblclick" ondblclick)
77                 (attribute "onmousedown" onmousedown)
78                 (attribute "onmouseup" onmouseup)
79                 (attribute "onmouseover" onmouseover)
80                 (attribute "onmousemove" onmousemove)
81                 (attribute "onmouseout" onmouseout)
82                 (attribute "onkeypress" onkeypress)
83                 (attribute "onkeydown" onkeydown)
84                 (attribute "onkeyup" onkeyup))))
85
86    (define html-b      (make-html-styler "b"))
87    (define html-big    (make-html-styler "big"))
88    (define html-cite   (make-html-styler "cite"))
89    (define html-code   (make-html-styler "code"))
90    (define html-dfn    (make-html-styler "dfn"))
91    (define html-em     (make-html-styler "em"))
92    (define html-i      (make-html-styler "i"))
93    (define html-kbd    (make-html-styler "kbd"))
94    (define html-samp   (make-html-styler "samp"))
95    (define html-small  (make-html-styler "small"))
96    (define html-strong (make-html-styler "strong"))
97    (define html-tt     (make-html-styler "tt"))
98    (define html-var    (make-html-styler "var"))
99
100    (define* (print (port: port (current-output-port)) . args)
101      (let pr ((x args))
102        (cond ((null? x))
103              ((pair? x)
104               (pr (car x))
105               (pr (cdr x)))
106              ((vector? x)
107               (pr (vector->list x)))
108              (else
109               (display x port)))))
110
111(test "<i id=water class=molecule><big>H</big><small>2</small><big>O</big></i>"
112      (with-output-to-string
113        (lambda ()
114          (print (html-i class: 'molecule
115                         id: 'water
116                         (html-big "H")
117                         (html-small "2")
118                         (html-big "O"))))))
119
120(define-macro* (foo (key: k 99))
121  `(list ',k) )
122
123(test '(99) (foo))
124(test '(100) (foo key: 100))
125
126(test-end)
Note: See TracBrowser for help on using the repository browser.