(library
  (functional-tests)

  (export
    info

    temp-file
    temp-file-containing
    slurp-file

    run
    run-with-exit-code
    run-ok
    run-fail

    scenario
    scenarios
    add-scenario
    list-scenarios
    describe-scenarios
    define-scenario
    fail
    run-scenario
    run-scenarios

    tools-version
    define-tool

    assert-equal
    assert-eof
    assert-starts-with)

  (import
    (chezscheme)
    (fmt fmt)
    (list-utils)
    (thin-xml)
    (utils)
    (srfi s8 receive)
    (only (srfi s1 lists) drop-while))

  ;;;--------------------------------------------------------------------

  (define (vector-sort-by cmp key-fn v)
    (define (compare x y)
      (cmp (key-fn x) (key-fn y)))

    (vector-sort compare v))

  (define (chomp line)
    (list->string
      (reverse
        (drop-while char-whitespace?
                    (reverse (string->list line))))))

  ;; FIXME: write a decent log library
  (define info-lines '())

  (define (info . args)
    (set! info-lines (cons (apply fmt #f args)
                           info-lines)))

  ;;;--------------------------------------------------------------------

  (define temp-file
    (let ((counter 0))
     (lambda ()
       (let loop ()
        (let ((path (fmt #f (cat (dsp "/tmp/thinp-functional-tests-")
                                 (pad-char #\0 (pad/left 4 (num counter)))))))
          (set! counter (+ counter 1))
          (if (file-exists? path) (loop) path))))))

  ;; Creates a temporary file with the specified contents.
  (define (temp-file-containing contents)
    (let ((path (temp-file)))
     (with-output-to-file path (lambda () (put-string (current-output-port) contents)))
     path))

  (define (slurp-file path)
    (define (slurp)
      (let ((output (get-string-all (current-input-port))))
       (if (eof-object? output)
           output
           (chomp output))))

    (with-input-from-file path slurp))

  ;;;--------------------------------------------------------------------
  ;;; Run a sub process and capture it's output.
  ;;; Ideally we'd use open-process-ports, but that loses us the exit code which
  ;;; we need for testing.  So we use system, and redirect stderr and stdout to
  ;;; temporary files, and subsequently read them in.  Messy, but fine for tests.

  (define (build-command-line cmd-and-args)
    (apply fmt #f (map dsp (intersperse " " cmd-and-args))))

  (define (run . cmd-and-args)
    (let ((stdout-file (temp-file))
          (stderr-file (temp-file)))
      (let ((cmd (fmt #f
                      (dsp (build-command-line cmd-and-args))
                      (dsp " > ")
                      (dsp stdout-file)
                      (dsp " 2> ")
                      (dsp stderr-file))))
        (info (dsp "cmd: ") (dsp cmd))
        (let ((exit-code (system cmd)))
         (values exit-code
                 (slurp-file stdout-file)
                 (slurp-file stderr-file))))))

  (define (run-with-exit-code pred cmd-and-args)
    (receive (exit-code stdout stderr) (apply run cmd-and-args)
             (if (pred exit-code)
                 (values stdout stderr)
                 (begin
                   (info (fmt #f (dsp "stdout: ") stdout))
                   (info (fmt #f (dsp "stderr: ") stderr))
                   (fail (fmt #f (dsp "unexpected exit code (")
                              (num exit-code)
                              (dsp ")")))))))

  (define (run-ok . cmd-and-args)
    (run-with-exit-code zero? cmd-and-args))

  (define (run-fail . cmd-and-args)
    (define (not-zero? x) (not (zero? x)))

    (run-with-exit-code not-zero? cmd-and-args))

  ;;;--------------------------------------------------------------------

  (define-record-type scenario (fields desc thunk))

  (define scenarios
    (make-hashtable equal-hash equal?))

  (define (add-scenario syms s)
    (hashtable-set! scenarios syms s))

  (define (fmt-keys prev-keys keys)
    (define (fmt-keys% n keys)
      (if (null? keys)
          fmt-null
          (cat (space-to n) (dsp (car keys)) (if (null? (cdr keys)) fmt-null nl)
               (fmt-keys% (+ n 2) (cdr keys)))))

    (let loop ((n 0)
               (keys keys)
               (prev-keys prev-keys))
      (if (and (not (null? keys))
               (not (null? prev-keys))
               (eq? (car keys) (car prev-keys)))
          (loop (+ n 2) (cdr keys) (cdr prev-keys))
          (begin
            (if (zero? n)
              (cat nl (fmt-keys% n keys))
              (fmt-keys% n keys))))))

  (define (list-scenarios)
    (define (fmt-keys ks)
      (fmt #f (dsp ks)))

    (vector->list
      (vector-sort-by string<? fmt-keys (hashtable-keys scenarios))))

  (define (fmt-scenarios keys fn)
    (define (flush)
      (flush-output-port (current-output-port)))

    (define (describe prev-keys keys)
      (fmt #t
           (cat (fmt-keys prev-keys keys)
                (dsp #\space)
                (pad-char #\. (space-to 38))
                (dsp #\space)))
      (flush)
      (fmt #t (cat (fn keys) nl))
      (flush))

    (for-each describe (cons '() (reverse (cdr (reverse keys)))) keys))

  (define (describe-scenarios keys)
    (fmt-scenarios keys
                   (lambda (keys)
                     (scenario-desc
                       (hashtable-ref scenarios keys #f)))))

  (define-syntax define-scenario
    (syntax-rules ()
      ((_ syms desc body ...)
       (add-scenario 'syms
                     (make-scenario desc
                                    (lambda ()
                                      body ...))))))

  (define (fail msg)
    (raise (condition
             (make-error)
             (make-message-condition msg))))

  (define (run-scenario syms)
    (let ((s (hashtable-ref scenarios syms #f)))
     (display syms)
     (display " ... ")
     ((scenario-thunk s))
     (display "pass")
     (newline)))

  ;; Returns #f if an error was raised, otherwise #t (the values from thunk are
  ;; discarded).
  (define (try thunk)
    (call/cc
      (lambda (k)
        (with-exception-handler
          (lambda (x)
            (if (error? x)
                (k #f)
                (raise x)))
            (lambda ()
              (thunk)
              #t)))))

  (define (run-scenarios ss)
    (let ((pass 0)
          (fail 0)
          (fail-keys '()))

      (fmt-scenarios ss
                     (lambda (keys)
                       (let ((s (hashtable-ref scenarios keys #f)))
                        (if (try (scenario-thunk s))
                            (begin (inc! pass)
                                   (dsp "pass"))
                            (begin (inc! fail)
                                   (set! fail-keys (cons keys fail-keys))
                                   (dsp "FAIL"))))))
      (fmt #t nl (dsp "There were failures:") nl)
      (fmt-scenarios fail-keys
                     (lambda (_)
                       (dsp "FAIL")))
      (fmt #t (cat nl
                   (num pass)
                   (dsp "/")
                   (num (+ pass fail))
                   (dsp " tests passed")
                   (if (zero? fail)
                       (dsp #\.)
                       (cat (dsp ", ")
                            (num fail)
                            (dsp " failures.")))
                   nl))))

  ;;-----------------------------------------------

  ;; FIXME: don't hard code this
  (define tools-version "0.7.0-rc6")

  (define (tool-name sym)
    (define (to-underscore c)
      (if (eq? #\- c) #\_ c))

    (list->string (map to-underscore (string->list (symbol->string sym)))))

  (define-syntax define-tool
    (syntax-rules ()
      ((_ tool-sym) (define (tool-sym . flags)
                      (apply run-ok (tool-name 'tool-sym) flags)))))

  (define (assert-equal str1 str2)
    (unless (equal? str1 str2)
      (fail (fmt #f (dsp "values differ: ")
                 (wrt str1)
                 (dsp ", ")
                 (wrt str2)))))

  (define (assert-eof obj)
    (unless (eof-object? obj)
      (fail (fmt #f (dsp "object is not an #!eof: ") (dsp obj)))))

  (define (starts-with prefix str)
    (and (>= (string-length str) (string-length prefix))
         (equal? (substring str 0 (string-length prefix))
                 prefix)))

  (define (assert-starts-with prefix str)
    (unless (starts-with prefix str)
      (fail (fmt #f (dsp "string should begin with: ")
                 (wrt prefix)
                 (dsp ", ")
                 (wrt str)))))


  )