;;;test "Gloss" API

(define-constant *test-gloss-marker* "--> ")

(define (test-group-ref group field . o)
  (define (assq-ref ls key . o)
    (cond
      ((assq key ls)    => cdr)
      ((pair? o)        (car o))
      (else             #f) ) )
  (apply assq-ref (cdr group) field o) )

(define test-indent-width)
(define test-first-indentation)
(define test-max-indentation)
(define test-indentation-char)
(let ()
  (import
    (chicken syntax)
    (only (chicken process-context) get-environment-variable))

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

  ;from miscmacros

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

  ;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 (
          (?locnam (cadr frm))
          (?typnam (caddr frm))
          (?body (cdddr frm))
          (_lambda (rnm 'lambda)) )
          `(,_lambda (obj)
            (,(symbol-append 'check- (strip-syntax ?typnam)) ',?locnam obj)
            ,@?body
            obj ) ) ) ) )

  ;from check-errors

  (define (positive-integer? obj) (and (integer? obj) (positive? obj)))

  (define (check-positive-integer loc obj)
    (unless (positive-integer? obj) (error loc "not a positive-integer" obj))
    obj )

  (define (check-char loc obj)
    (unless (char? obj) (error loc "not a char" obj))
    obj )

  (set! test-indent-width
    (make-parameter
      (get-environment-variable/default "TEST_INDENT_WIDTH" 4)
      (checked-guard test-indent-width positive-integer)))
  (set! test-first-indentation
    (make-parameter
      (get-environment-variable/default "TEST_FIRST_INDENTATION" 1)
      (checked-guard test-first-indentation positive-integer)))
  (set! test-max-indentation
    (make-parameter
      (get-environment-variable/default "TEST_MAX_INDENTATION" 5)
      (checked-guard test-max-indentation positive-integer)))
  (set! test-indentation-char
    (make-parameter
      (string-ref (get-environment-variable/default "TEST_INDENTATION_CHAR" " ") 0)
      (checked-guard test-indentation-char char))) )

(define (test-group-indent-string group)
  (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)) )
  (make-string (test-group-indent-width group) (test-indentation-char)) )

(define-syntax gloss
  (syntax-rules ()
    ((gloss)
      (newline) )
    ((gloss ?obj ...)
      (begin
        (display (test-group-indent-string (current-test-group)))
        (display *test-gloss-marker*)
        (for-each display (list ?obj ...))
        (newline)) ) ) )

;(import (only (chicken format) format))
(define (glossf fmt . args)
  (gloss (apply format #f fmt args)) )