280 lines
7.6 KiB
Scheme
280 lines
7.6 KiB
Scheme
;;; test "Gloss" API
|
|
|
|
(module (test-utils gloss support)
|
|
|
|
(;export
|
|
;
|
|
check-char
|
|
check-string
|
|
check-fixnum
|
|
check-exact-unsigned-integer
|
|
check-unsigned-fixnum
|
|
define-checked-item
|
|
;
|
|
test-indent-width
|
|
test-first-indentation
|
|
test-max-indentation
|
|
test-indentation-char
|
|
;
|
|
test-group-level
|
|
test-group-indent-width
|
|
test-group-indent-string)
|
|
|
|
(import scheme
|
|
(scheme case-lambda)
|
|
(chicken base)
|
|
(chicken syntax)
|
|
(only (chicken process-context) get-environment-variable))
|
|
|
|
;NOTE yes, order matters, i guess
|
|
(cond-expand
|
|
(use-parameter)
|
|
(use-variable
|
|
(import (chicken module))
|
|
(export make-variable) ) )
|
|
|
|
(cond-expand
|
|
((or use-parameter use-variable)
|
|
;from (moremacros:)
|
|
(import-for-syntax (only (chicken base) symbol-append))
|
|
(define-syntax checked-guard
|
|
(er-macro-transformer
|
|
(lambda (frm rnm cmp)
|
|
(##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
|
|
(let ((_lambda (rnm 'lambda))
|
|
(_let (rnm 'let))
|
|
(_arg (rnm 'arg))
|
|
(?locnam (cadr frm))
|
|
(?typnam (caddr frm))
|
|
(?body (cdddr frm)) )
|
|
(let ((chknam (symbol-append 'check- (strip-syntax ?typnam)))) ;inject
|
|
`(,_lambda (,_arg)
|
|
(,chknam ',?locnam ,_arg)
|
|
(,_let ((obj ,_arg))
|
|
,@?body
|
|
obj ) ) ) ) ) ) ) )
|
|
(else) )
|
|
|
|
(cond-expand
|
|
(use-parameter
|
|
;from (moremacros:)
|
|
(define-syntax define-parameter
|
|
(syntax-rules ()
|
|
((define-parameter name value guard)
|
|
(define name (make-parameter value guard)))
|
|
((define-parameter name value)
|
|
(define name (make-parameter value)))
|
|
((define-parameter name)
|
|
(define name (make-parameter (void))))))
|
|
(define-syntax define-checked-parameter
|
|
(syntax-rules ()
|
|
((define-checked-parameter ?name ?init ?typnam ?body0 ...)
|
|
(define-parameter ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )
|
|
(define-syntax define-checked-item
|
|
(syntax-rules ()
|
|
((define-checked-item ?name ?init ?typnam ?body0 ...)
|
|
(define-checked-parameter ?name ?init ?typnam ?body0 ...) ) ) ) )
|
|
(use-variable
|
|
;from (moremacros: variable-item)
|
|
(define (make-variable init #!optional (guard identity))
|
|
(let ((value (guard init)))
|
|
(define (setter obj) (set! value (guard obj)))
|
|
(getter-with-setter
|
|
;ugly but like parameter
|
|
(lambda args
|
|
(if (null? args) value
|
|
(let ((new (car args)))
|
|
(setter new)
|
|
new ) ) )
|
|
;emphasize not a paramter
|
|
setter) ) )
|
|
(define-syntax define-variable
|
|
(syntax-rules ()
|
|
((define-variable ?name ?init) (define ?name (make-variable ?init)) )
|
|
((define-variable ?name ?init ?guard) (define ?name (make-variable ?init ?guard)) ) ) )
|
|
(define-syntax define-checked-variable
|
|
(syntax-rules ()
|
|
((define-checked-variable ?name ?init ?typnam ?body0 ...)
|
|
(define-variable ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )
|
|
(define-syntax define-checked-item
|
|
(syntax-rules ()
|
|
((define-checked-item ?name ?init ?typnam ?body0 ...)
|
|
(define-checked-variable ?name ?init ?typnam ?body0 ...) ) ) ) ) )
|
|
|
|
;(check-errors sys)
|
|
|
|
(define (check-char loc obj) (##sys#check-char obj loc) obj)
|
|
(define (check-string loc obj) (##sys#check-string obj loc) obj)
|
|
(define (check-fixnum loc obj) (##sys#check-fixnum obj loc) obj)
|
|
(define (check-exact-unsigned-integer loc obj) (##sys#check-exact-uinteger obj loc) obj)
|
|
|
|
(define (check-unsigned-fixnum loc obj) (check-exact-unsigned-integer loc (check-fixnum loc obj)) obj)
|
|
|
|
;from posix-utils (?)
|
|
|
|
(define get-environment-variable/default
|
|
(case-lambda
|
|
((nm)
|
|
(get-environment-variable/default nm #f))
|
|
((nm def)
|
|
(cond ((get-environment-variable nm) => string->number)
|
|
(else def))) ) )
|
|
|
|
;;
|
|
|
|
(define (check-indentation-amount loc obj) (check-unsigned-fixnum loc obj))
|
|
|
|
(define-checked-item test-indent-width
|
|
(get-environment-variable/default "TEST_INDENT_WIDTH" 4)
|
|
indentation-amount)
|
|
|
|
(define-checked-item test-first-indentation
|
|
(get-environment-variable/default "TEST_FIRST_INDENTATION" 1)
|
|
indentation-amount)
|
|
|
|
(define-checked-item test-max-indentation
|
|
(get-environment-variable/default "TEST_MAX_INDENTATION" 5)
|
|
indentation-amount)
|
|
|
|
(define-checked-item test-indentation-char
|
|
(string-ref (get-environment-variable/default "TEST_INDENTATION_CHAR" " ") 0)
|
|
char)
|
|
|
|
;;
|
|
|
|
;test?
|
|
|
|
(define (assq-ref ls key . args)
|
|
(cond ((assq key ls) => cdr)
|
|
((pair? args) (car args))
|
|
(else #f)) )
|
|
|
|
(define (test-group-ref group field . args)
|
|
(apply assq-ref (cdr group) field args) )
|
|
|
|
;;
|
|
|
|
(define (*test-group-level group)
|
|
(add1 (- (test-group-ref group 'level 0) (test-first-indentation))) )
|
|
|
|
(define (test-group-level group)
|
|
(min (test-max-indentation) (max 0 (*test-group-level group))) )
|
|
|
|
(define (test-group-indent-width group)
|
|
(* (test-indent-width) (test-group-level group)) )
|
|
|
|
(define (test-group-indent-string group)
|
|
(if (not group) ""
|
|
(make-string (test-group-indent-width group) (test-indentation-char))) )
|
|
|
|
) ;module (test-utils gloss support)
|
|
|
|
;;
|
|
|
|
(module (test-utils gloss basic)
|
|
|
|
(;export
|
|
;
|
|
test-gloss-marker
|
|
;
|
|
glossln
|
|
(glossn display-gloss-marker)
|
|
gloss)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken syntax)
|
|
test
|
|
(test-utils gloss support))
|
|
|
|
;;
|
|
|
|
(define-constant TEST-GLOSS-MARKER "-->")
|
|
|
|
(define-checked-item test-gloss-marker TEST-GLOSS-MARKER string)
|
|
|
|
(define (display-gloss-marker)
|
|
(display (test-group-indent-string (current-test-group)))
|
|
(display (test-gloss-marker))
|
|
(display #\space) )
|
|
|
|
;;
|
|
|
|
(define-syntax glossln
|
|
(syntax-rules ()
|
|
((glossln)
|
|
(begin (newline) (flush-output) ) ) ) )
|
|
|
|
(define-syntax glossn
|
|
(syntax-rules ()
|
|
((glossn)
|
|
(begin) )
|
|
((glossn ?obj)
|
|
(begin (display-gloss-marker) (display ?obj)))
|
|
((glossn ?obj ...)
|
|
(begin
|
|
(display-gloss-marker)
|
|
(for-each (lambda (x) (display x) (display #\space)) (list ?obj ...))) ) ) )
|
|
|
|
(define-syntax gloss
|
|
(syntax-rules ()
|
|
((gloss)
|
|
(glossln) )
|
|
((gloss ?obj ...)
|
|
(begin (glossn ?obj ...) (glossln)) ) ) )
|
|
|
|
) ;module (test-utils gloss basic)
|
|
|
|
;; Formatted Gloss
|
|
|
|
;Needs a format, builtin or egg
|
|
;(import (test gloss format) (only (chicken format) format))
|
|
;(import (test gloss format) format)
|
|
|
|
(module (test-utils gloss format)
|
|
|
|
(;export
|
|
glossnf
|
|
glossf)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken syntax)
|
|
test
|
|
(test-utils gloss basic))
|
|
|
|
(define-syntax glossnf
|
|
(syntax-rules ()
|
|
((glossnf ?fmt ?arg0 ...)
|
|
(glossn (format #f ?fmt ?arg0 ...)) ) ) )
|
|
|
|
(define-syntax glossf
|
|
(syntax-rules ()
|
|
((glossf ?fmt ?arg0 ...)
|
|
(begin (glossnf ?fmt ?arg0 ...) (glossln) ) ) ) )
|
|
|
|
) ;module (test-utils gloss format)
|
|
|
|
(module (test-utils gloss) ()
|
|
|
|
(import scheme (chicken module))
|
|
|
|
(cond-expand
|
|
(use-parameter
|
|
(import (test-utils gloss support))
|
|
(reexport
|
|
(except (test-utils gloss support)
|
|
check-char check-string check-fixnum check-exact-unsigned-integer
|
|
check-unsigned-fixnum define-checked-item)) )
|
|
(use-variable
|
|
(import (except (test-utils gloss support) make-variable))
|
|
(reexport
|
|
(except (test-utils gloss support)
|
|
make-variable
|
|
check-char check-string check-fixnum check-exact-unsigned-integer
|
|
check-unsigned-fixnum define-checked-item)) ) )
|
|
|
|
(import (test-utils gloss basic) (test-utils gloss format))
|
|
(reexport (test-utils gloss basic) (test-utils gloss format))
|
|
|
|
) ;(test-utils gloss)
|