;;;; test-driver.scm --- SRFI-64 custom driver for GNU Automake test suites.

(define script-version "2015-11-01.01") ;UTC

;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;;; Commentary:
;;;
;;; This script provides a custom test driver for GNU Automake using the
;;; SRFI-64 Scheme API for test suites.
;;;
;;;; Code:

(use-modules (ice-9 getopt-long)
             (ice-9 pretty-print)
             (srfi srfi-64))

(define (show-help)
  (display "Usage:
  test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
              [--expect-failure={yes|no}] [--color-tests={yes|no}]
              [--enable-hard-errors={yes|no}] [--]
              TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))

(define %options
  '((test-name                 (value #t))
    (log-file                  (value #t))
    (trs-file                  (value #t))
    (color-tests               (value #t))
    (expect-failure            (value #t)) ;XXX: not implemented yet
    (enable-hard-errors        (value #t)) ;XXX: not implemented in SRFI-64
    (help    (single-char #\h) (value #f))
    (version (single-char #\V) (value #f))))

(define* (test-display field value  #:optional (port (current-output-port)))
  "Display \"FIELD: VALUE\\n\" on PORT."
  (format port "~A: ~A\n" field value))

(define* (result->string symbol #:key colorize)
  "Return SYMBOL as an upper case string.  Use colors when COLORIZE is #t."
  (let ((result (string-upcase (symbol->string symbol))))
    (if colorize
        (string-append (case symbol
                         ((pass)       "")  ;green
                         ((xfail)      "")  ;light green
                         ((skip)       "")  ;blue
                         ((fail xpass) "")  ;red
                         ((error)      "")) ;magenta
                       result
                       "")          ;no color
        result)))

(define* (test-runner-gnu test-name #:key color-tests out-port trs-port)
  "Return an custom SRFI-64 test runner.  The current output port is supposed
to be redirected to a '.log' file."

  (define (test-on-test-begin-gnu runner)
    "Procedure called at the start of an individual test-case, before the test
expression (and expected value) are evaluated."
    (let ((results (test-result-alist runner)))
      (test-display "test-name" (assq-ref results 'test-name))
      (test-display "location"
                    (string-append
                     (assq-ref results 'source-file) ":"
                     (number->string (assq-ref results 'source-line))))
      (display "source:\n")
      (pretty-print (assq-ref results 'source-form) #:per-line-prefix "+ ")))

  (define (test-on-test-end-gnu runner)
    "Procedure called at the end of an individual testcase, when the result of
the test is available."
    (let ((results (test-result-alist runner)))
      ;; Display the result of the test on the console (with colors).
      (test-display
       (result->string (test-result-kind runner) #:colorize color-tests)
       (string-append test-name " - " (test-runner-test-name runner))
       out-port)
      (when (assq 'actual-value results)
        (test-display "value" (assq-ref results 'actual-value)))
      (test-display "result" (result->string (assq-ref results 'result-kind)))
      (newline)
      (test-display ":test-result"
                    (string-append (result->string (test-result-kind runner))
                                   " " (test-runner-test-name runner))
                    trs-port)))

  (define (test-on-group-end-gnu runner)
    "Procedure meant to be called by a `test-end', including at the end of a
test-group."
    (let ((fail (or (positive? (test-runner-fail-count runner))
                    (positive? (test-runner-xpass-count runner))))
          (skip (or (positive? (test-runner-skip-count runner))
                    (positive? (test-runner-xfail-count runner)))))
      ;; XXX: Since multiple tests share one '.trs' file, we need to choose
      ;; what to report in the "global" results which would require more
      ;; refinements.
      (test-display ":global-test-result" (if fail "FAIL" "PASS") trs-port)
      (test-display ":recheck" (if fail "yes" "no") trs-port)
      (test-display ":copy-in-global-log" (if (or fail skip) "yes" "no") trs-port)
      #f))

  (let ((runner (test-runner-null)))
    (test-runner-on-test-begin! runner test-on-test-begin-gnu)
    (test-runner-on-test-end! runner test-on-test-end-gnu)
    (test-runner-on-group-end! runner test-on-group-end-gnu)
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
    runner))


;;;
;;; Entry point.
;;;

(define (main . args)
  (let ((opts (getopt-long (command-line) %options)))
    (when (option-ref opts 'help #f)
      (show-help)
      (exit 0))
    (when (option-ref opts 'version #f)
      (format #t "test-driver.scm ~A" script-version)
      (exit 0))
    (let ((trs (open-output-file (option-ref opts 'trs-file ""))))
      (test-runner-current
       (test-runner-gnu (option-ref opts 'test-name #f)
                        #:out-port (current-output-port)
                        #:trs-port trs
                        #:color-tests (option-ref opts 'color-tests #f)))
      (with-output-to-file (option-ref opts 'log-file "")
        (lambda ()
          (set-current-error-port (current-output-port))
          (load-from-path (option-ref opts 'test-name #f))))
      (close-port trs)
      (exit 0))))

;;; Local Variables:
;;; eval: (add-hook 'write-file-functions 'time-stamp)
;;; time-stamp-start: "(define script-version \""
;;; time-stamp-format: "%:y-%02m-%02d.%02H"
;;; time-stamp-time-zone: "UTC"
;;; time-stamp-end: "\") ;UTC"
;;; End:

;;;; test-driver.scm ends here.