test-utils/test-utils.gloss.scm

;;; 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)