;;;; test-utils.test.scm  -*- Scheme -*-

(module (test-utils test)

(;export
  ;
  sort/key
  sort</ref
  ;
  test-each
  test-assert-each
  test-assert-times
  test-times)

(cond-expand
  (chicken-5
    (import scheme) )
  (chicken-6
    (import (scheme base)) )
  (else
    (error "unknown CHICKEN") ) )
(import
  (chicken base)
  (chicken type)
  (only (chicken sort) sort)
  (only (chicken string) ->string))

;FIXME forall (a (b (s
(: sort/key ((or (list-of 'a) (vector-of 'a))
              #!optional ('b 'b -> boolean)
                         ('a -> 'b)
            -> (or (list-of 'a) (vector-of 'a))))

(: sort</ref ((or (list-of 'a) (vector-of 'a))
                #!optional (or false fixnum)
              -> (or (list-of 'a) (vector-of 'a))))

;;

(define (empty-seq? x)
  (if (list? x) (null? x)
      (zero? (vector-length x))) )

(define (key-of x nth)
  (if (list? x) (list-ref x nth)
      (vector-ref x nth)) )

(define (key-nth nth)
  (cond ((not nth)      identity)
        ((fixnum? nth)  (cut key-of <> nth))
        (else
          (error 'key "bad argument type - not an index" nth))) )

(define (sort/key seq #!optional (pred <) (key identity))
  (define (rf<? a b) (pred (key a) (key b)))
  (sort seq rf<?) )

(define (sort</ref seq #!optional nth)
  (if (empty-seq? seq) seq
      (let ((elm (key-of seq 0)) ;FIXME when empty?
            (key (key-nth nth)) )
        (cond ((symbol? elm)
                (sort/key seq string<? (o symbol->string key)))
              ((string? elm)
                (sort/key seq string<? key))
              ((number? elm)
                (sort/key seq < key))
              (else
                (sort/key seq string<? (o ->string key)))) ) ) )

;FIXME title & test value from bindings, multiple values

(define-syntax test-assert-each
  (syntax-rules ()
    ((test-assert-each ?ttl (?a0 ...) ?e ?l0 ...)
      (let ((_ttl ?ttl))
        (define (test-each-body)
          (let ((nth 0))
            (call-with-current-continuation
              (lambda (return)
                (for-each
                  (lambda (?a0 ...)
                    (set! nth (+ nth 1))
                    (unless ?e (return #f nth)) )
                  ?l0 ...)
                (values #t nth) ) ) ) )
        (let-values (((all-pass nth) (test-each-body)))
          (let ((msg (if all-pass _ttl
                         (string-append _ttl " (@ #" (number->string nth) ")"))))
            (test-assert msg all-pass) ) ) ) ) ) )

(define-syntax test-each
  (syntax-rules ()
    ((test-each ?ttl ?vs (?a0 ...) ?e ?l0 ...)
      (let ((_tst (current-test-comparator)))
        (test-assert-each ?ttl (v ?a0 ...) (_tst v ?e) ?vs ?l0 ...) ) ) ) )

(define-syntax test-assert-times
  (syntax-rules ()
    ((test-assert-times ?ttl ?n ?e)
      (let ((_ttl ?ttl) (_n ?n))
        (call-with-current-continuation
          (lambda (return)
            (do ((i 0 (+ i 1)))
                ((= i _n) (test-assert _ttl #t))
              (unless ?e
                (let ((msg (string-append _ttl " (@ #" (number->string (+ i 1)) ")")))
                  (return (test-assert msg #f)) ) ) ) ) ) ) ) ) )

(define-syntax test-times
  (syntax-rules ()
    ((test-times ?ttl ?n ?v ?e)
      (let ((_tst (current-test-comparator)))
        (test-assert-times ?ttl ?n (_tst ?v ?e)) ) ) ) )

) ;module (test-utils test)