source: project/release/5/apropos-srfi/trunk/tests/test-gloss.incl.scm @ 38544

Last change on this file since 38544 was 38544, checked in by Kon Lovett, 6 months ago

add gloss, srfi info includes uri, verbose csi info

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