source: project/release/5/moremacros/trunk/tests/test-gloss.incl.scm @ 38730

Last change on this file since 38730 was 38730, checked in by Kon Lovett, 4 months ago

include test gloss

File size: 4.0 KB
Line 
1
2;;; test "Gloss" API
3
4;;
5
6(define test-indent-width)
7(define test-first-indentation)
8(define test-max-indentation)
9(define test-indentation-char)
10(let ()
11  (import (chicken syntax))
12  (import (only (chicken process-context) get-environment-variable))
13
14  (define get-environment-variable/default
15    (case-lambda
16      ((nm)
17        (get-environment-variable/default nm #f))
18      ((nm def)
19        (cond
20          ((get-environment-variable nm)
21            => string->number)
22          (else
23            def))) ) )
24
25  ;from miscmacros
26
27  (define-syntax define-parameter
28    (syntax-rules ()
29      ((define-parameter name value guard)
30       (define name (make-parameter value guard)))
31      ((define-parameter name value)
32       (define name (make-parameter value)))
33      ((define-parameter name)
34       (define name (make-parameter (void))))))
35
36  ;from moremacros
37
38  (import-for-syntax (only (chicken base) symbol-append))
39
40  (define-syntax checked-guard
41    (er-macro-transformer
42      (lambda (frm rnm cmp)
43        (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
44        (let (
45          (?locnam (cadr frm))
46          (?typnam (caddr frm))
47          (?body (cdddr frm))
48          (_lambda (rnm 'lambda)) )
49          `(,_lambda (obj)
50            (,(symbol-append 'check- (strip-syntax ?typnam)) ',?locnam obj)
51            ,@?body
52            obj ) ) ) ) )
53
54  ;from check-errors
55
56  (define (indentation-amount? obj) (and (integer? obj) (exact? obj) (positive? obj)))
57
58  (define (check-indentation-amount loc obj)
59    (unless (indentation-amount? obj) (error loc "not a positive exact integer" obj))
60    obj )
61
62  (define (check-char loc obj)
63    (unless (char? obj) (error loc "not a char" obj))
64    obj )
65
66  (set! test-indent-width
67    (make-parameter
68      (get-environment-variable/default "TEST_INDENT_WIDTH" 4)
69      (checked-guard test-indent-width indentation-amount)))
70  (set! test-first-indentation
71    (make-parameter
72      (get-environment-variable/default "TEST_FIRST_INDENTATION" 1)
73      (checked-guard test-first-indentation indentation-amount)))
74  (set! test-max-indentation
75    (make-parameter
76      (get-environment-variable/default "TEST_MAX_INDENTATION" 5)
77      (checked-guard test-max-indentation indentation-amount)))
78  (set! test-indentation-char
79    (make-parameter
80      (string-ref (get-environment-variable/default "TEST_INDENTATION_CHAR" " ") 0)
81      (checked-guard test-indentation-char char))) )
82
83;;
84
85;from test?
86(define (test-group-ref group field . o)
87  (define (assq-ref ls key . o)
88    (cond
89      ((assq key ls)    => cdr)
90      ((pair? o)        (car o))
91      (else             #f) ) )
92  (apply assq-ref (cdr group) field o) )
93
94;;
95
96(define-constant TEST-GLOSS-MARKER "--> ")
97
98(define (test-group-indent-string group)
99  (define (*test-group-level group)
100    (add1 (- (test-group-ref group 'level 0) (test-first-indentation))) )
101  (define (test-group-level group)
102    (min (test-max-indentation) (max 0 (*test-group-level group))) )
103  (define (test-group-indent-width group)
104    (* (test-indent-width) (test-group-level group)) )
105  (make-string (test-group-indent-width group) (test-indentation-char)) )
106
107(define (display-gloss-marker)
108  (display (test-group-indent-string (current-test-group)))
109  (display TEST-GLOSS-MARKER) )
110
111;;
112
113(define-syntax glossn
114  (syntax-rules ()
115    ((glossn)
116      (begin))
117    ((glossn ?obj)
118      (begin
119        (display-gloss-marker)
120        (display ?obj)
121        (flush-output)) )
122    ((glossn ?obj ...)
123      (begin
124        (display-gloss-marker)
125        (for-each display (list ?obj ...))
126        (flush-output)) ) ) )
127
128(define-syntax gloss
129  (syntax-rules ()
130    ((gloss)
131      (newline))
132    ((gloss ?obj ...)
133      (begin
134        (glossn ?obj ...)
135        (newline)) ) ) )
136
137;Needs a format:
138;(import (only (chicken format) format)) ;builtin
139;(import format)                         ;egg
140
141(define-syntax glossnf
142  (syntax-rules ()
143    ((glossnf ?fmt ?arg0 ...)
144      (glossn (format #f ?fmt ?arg0 ...)) ) ) )
145
146(define-syntax glossf
147  (syntax-rules ()
148    ((glossf ?fmt ?arg0 ...)
149      (begin
150        (glossnf ?fmt ?arg0 ...)
151        (newline)) ) ) )
Note: See TracBrowser for help on using the repository browser.