;;; test "Gloss" API

(module (test gloss support)

(;export
  ;Parameters
  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 ;utf8
  (chicken base)
  (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 (check-char loc obj) (##sys#check-char obj loc) obj)
(define (check-exact-unsigned-integer loc obj) (##sys#check-exact-uinteger obj loc) obj)

;;

(define (check-indentation-amount loc obj) (check-exact-unsigned-integer loc obj))

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

;;

;from test?

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

;;

(module (test gloss basic)

(;export
  glossln
  (glossn display-gloss-marker)
  gloss)

(import scheme ;utf8
  (chicken base)
  (chicken syntax)
  test
  (test gloss support))

;;

(define-constant TEST-GLOSS-MARKER "-->")

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

;; Formatted Gloss

(module (test gloss format)

(;export
  glossnf
  glossf)

(import scheme ;utf8
  (chicken base)
  (chicken syntax)
  test
  (test gloss basic))

;Needs a format:
;(import (only (chicken format) format)) ;builtin
;(import format)                         ;egg

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

;;

(import (test gloss basic) (test gloss format))