;; Run the unit tests.
;;
;; The unit tests contain arbitrary scheme code, but include a number
;; of (test-suite "label" expr ...) forms, using the macros in s7unit.scm.
;;
;; These can be used two ways:
;;
;;   * `./beastie test-foo.scm` :
;;     A file of tests can (load "s7unit.scm"), and when this is run
;;     by beastie, the various `(test-suite ...)` forms will be evaluated.
;;   * `./beastie s7unit.scm` or
;;     `./beastie s7unit.scm test-foo.scm` or
;;     `./beastie s7unit.scm test-foo.scm:label` :
;;     Run `s7unit.scm` either with no arguments, or with one or more files
;;     containing `(test-suite ...)` forms.  If no arguments are
;;     present, then search for all of the `test-*.scm` files and load them.
;;     If the file is of the form `filename.scm:label`, then the suite runs
;;     only the test with the given label in `filename.scm`.
;;
;; Exit with status 0 if all the test-suites pass.  Exit non-zero if
;; any of the suites fail.  Whenever an assertion fails, we abandon
;; the test-suite.
;;
;; Modules using this support should be structured as
;;
;;    (test-suite
;;      "suite name"
;;      (assert-equal ...)
;;      ...)
;;    ...
;;    (exit/failures)  ; exit with non-zero status on any test-suite failures
;;
;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2024 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

;;(print-warning 'push #f)  ; let individual files suppress these instead

;; here, we want everything to be printed fully
(set! (*s7* 'print-length) (*s7* 'most-positive-fixnum))

(define-macro (%module-verbosity-flag%) 2048)

(define *THIS-FILE* "s7unit.scm")

;; requires BEASTIE_LOAD_PATH=s7-yyyy-mm-dd
;; (load "debug.scm")
;; (set! (debug-stack) (make-vector 8))

;; beastie.c sets the following, but if I want to get still
;; more prolix stacktraces, then we can increase the numbers here.
;; (set! (*s7* 'stacktrace-defaults)
;;       '(30 80 120 80 #f))

;; count the number of failed test-suite forms
(define signal-failures
  (let ((total-failures 0))
    (lambda args
      (if (null? args)
          total-failures
          (set! total-failures (+ total-failures (car args)))))))
(module-provide signal-failures)

(define/provide (exit/failures)
  (let ((nfails (signal-failures)))
    (if (> nfails 0)
        (let ((warnings (print-warning 'get-list)))
          (when (> (length warnings) 0)
            (format (current-error-port) "  Warnings: ~s~%" (length warnings)))
          (format #t "Failures: ~s~%" nfails)
          (exit 1))
        (begin
          ;; we delete temporaries only when we exit with success
          ;; (should we just delete them anyway?)
          (delete-temporary-files*!)
          (exit 0)))))

(define/provide (red-text s)
  (sprintf " ~a " s))
(define/provide (green-text s)
  (sprintf " ~a " s))

;; The macros below assume that there will be a function inc-good in
;; the environment, when they are expanded.
(define (assert-equal* suite-label test-label good+ bail-out actual expected)
  (print-info "equal? ~s" test-label)
  (if (equal? actual expected)
      (good+)
      (bail-out (list suite-label test-label actual expected))))

;; (ASSERT-EQUAL [test-label] actual expected)
;; Asserts that the two arguments are equal?
;; If `test-label` is present, it is used as the label for the string,
;; otherwise `actual` is used.
(define-macro (assert-equal . args)
  (case (length args)
    ((2) `(assert-equal* suite-label
                         (quote ,(car args))
                         inc-good bail-out
                         ,(car args) ,(cadr args)))
    ((3) `(assert-equal* suite-label
                         (quote ,(car args))
                         inc-good bail-out
                         ,(cadr args) ,(caddr args)))
    (else
     (beastie-error
      's7unit
      "wrong number of arguments to assert-equal"))))

(define (assert-eqv* suite-label test-label good+ bail-out actual expected)
  (print-info "eqv? ~s" test-label)
  (if (eqv? actual expected)
      (good+)
      (bail-out (list suite-label test-label actual expected))))

;; (ASSERT-EQV [test-label] actual expected)
;; Asserts that the two arguments are eqv?
;; If `test-label` is present, it is used as the label for the string,
;; otherwise `actual` is used.
(define-macro (assert-eqv . args)
  (case (length args)
    ((2) `(assert-eqv* suite-label
                       (quote ,(car args))
                       inc-good bail-out
                       ,(car args) ,(cadr args)))
    ((3) `(assert-eqv* suite-label
                       (quote ,(car args))
                       inc-good bail-out
                       ,(cadr args) ,(caddr args)))
    (else
     (beastie-error
      's7unit
      "wrong number of arguments to assert-eqv"))))

(module-provide assert-equal assert-equal* assert-eqv assert-eqv*)

(define (assert-exception* suite-label test-label good+ bail-out expected-tag expected-re thunk)
  (print-info "exception? ~s" test-label)
  (catch #t
    (lambda ()
      (let ((v (thunk)))
        (bail-out (list suite-label
                        test-label
                        (format #f "succeeded with value ~s" v)
                        (format #f "error:~s" expected-tag)))))
    (lambda (actual-tag . rest)
      ;(eprintf "  actual-tag=~s~%  rest=~s~%  test-label=~s~%" actual-tag rest test-label)
      (if (eqv? expected-tag actual-tag)
          (if expected-re
              (if (regexp-match? expected-re (caar rest))
                  (good+)
                  (begin
                    (print-info "assert-exception: produced ~s" rest)
                    (bail-out (list suite-label
                                    test-label
                                    (format #f "error with text: ~a" (caar rest))
                                    ;; why oh why does the following produce error/garbage?
                                    ;;(format #f "error matching ~s" expected-re)
                                    "error matching regexp"))))
              (good+))
          (begin
            (print-info "assert-exception: produced ~s" rest)
            (bail-out (list suite-label
                            test-label
                            (format #f "error:~s" actual-tag)
                            (format #f "error:~s" expected-tag))))))))

;; (ASSERT-EXCEPTION body ...)
;; (ASSERT-EXCEPTION :tag tag :body body :re re)
;;
;; The first case confirms that the (body ...) throws an exception of type 'beastie.
;; The second allows one to specify the expected tag (eg `:tag io-error`)
;; and a regexp (either as `(regexp ....)` or as a string) that the error message must match.
(define-macro* (assert-exception (body #f) (tag beastie) (re #f))
  `(assert-exception* suite-label
                      (quote ,body)
                      inc-good bail-out
                      (quote ,tag)
                      (let ((r ,re)) (if (string? r) (regexp r) r))
                      (lambda () ,body)))
(module-provide assert-exception assert-exception*)

(define (assert-true* suite-label test-label good+ bail-out actual)
  (print-info "true? ~s" test-label)
  (if (and (not (undefined? actual))    ;s7: #<undefined> is non-#f, thus true
           actual)
      (good+)
      (bail-out (list suite-label test-label actual 'true))))

;; Asserts that the argument is non-#f
(define-macro (assert-true actual)
  `(assert-true* suite-label
                 (quote ,actual)
                 inc-good bail-out
                 ,actual))
(module-provide assert-true assert-true*)

(define (assert-false* suite-label test-label good+ bail-out actual)
  (print-info "false? ~s" test-label)
  (if actual
      (bail-out (list suite-label test-label actual #f))
      (good+)))

;; Asserts that the argument is #f
(define-macro (assert-false actual)
  `(assert-false* suite-label
                  (quote ,actual)
                  inc-good bail-out
                  ,actual))
(module-provide assert-false assert-false*)

(define (assert-fail* suite-label test-label msg bail-out)
  (print-info msg)
  (bail-out (list suite-label test-label msg "forced-fail")))

;; Fail without testing anything.
;; If there is an 'expected' argument, then print that as an explanation
(define-macro (assert-fail label . expected)
  `(assert-fail* suite-label ,label
                 ,(if (null? expected) "forced-fail" (car expected))
                 bail-out))
(module-provide assert-fail assert-fail*)

;; (with-more-verbosity expr...)
;; evaluate the expr... with verbosity turned up
(define-macro (with-more-verbosity expr . exprs)
  `(dynamic-wind
       (λ () (verbosity 'up))
       (λ () ,expr . ,exprs)
       (λ () (verbosity 'down))))
(module-provide with-more-verbosity)

;; Given two objects A and B, which will typically (but not
;; necessarily) be lists, return #f if they are EQUAL?, and a string
;; otherwise, where the string aims to explain where the first
;; difference is.
(define (list-first-diff a b)
  ;(eprintf "list-first-diff |~s| ? |~s|~%" a b)
  (cond ((equal? a b) #f)
        ;; ((null? a) (format #f "second has trailing ~s" b))
        ;; ((null? b) (format #f "first has trailing ~s" a))
        ((not (or (list? a) (list? b))) ;neither is a list
         (format #f "a=|~s|  b=|~s| equal=~s~%" a b (equal? a b)))
        ((and (list? a) (list? b))
         (let loop ((la a)
                    (lb b))
           #;(format (current-error-port)
                   "  la=~s  lb=~s  (type? la ~s, type? lb ~s, eq? ~s, equal? ~s  eqv? ~s  equivalent? ~s)~%"
                   la lb
                   (type-of la) (type-of lb)
                   (eq? la lb)
                   (eqv? la lb)
                   (equal? la lb)
                   (equivalent? la lb))
           ;; a and b can't both be null, or else they would have matched the first stanza
           (cond ((null? la) (format #f "a null, b=~s" lb))
                 ((null? lb) (format #f "b null, a=~s" la))
                 ((and (list? la) (list? lb))
                  (let ((diff (list-first-diff (car la) (car lb))))
                    (or diff (loop (cdr la) (cdr lb)))))
                 (else                  ;improper list?
                  (if (equal? la lb)
                      #f
                      (format #f "a=~s  b=~s" la lb))))))
        (else (format #f "~s and ~s are not the same type of thing" a b))))

(define (string-first-diff a b)
  (let loop ((al (string->list a))
             (bl (string->list b))
             (pos 0))
    (cond ((and (null? al) (null? bl))
           "Not difference")
          ((null? al) (sprintf "first list short"))
          ((null? bl) (sprintf "second list short"))
          ((char=? (car al) (car bl)) (loop (cdr al) (cdr bl) (+ pos 1)))
          (else
           (sprintf "differ at pos ~a: ~a != ~a: ~s vs. ~s"
                    pos
                    (if (char-graph? (car al)) (car al) (sprintf "0x~x" (char->integer (car al))))
                    (if (char-graph? (car bl)) (car bl) (sprintf "0x~x" (char->integer (car bl))))
                    (list->string
                     (if (< (length al) 10) al (take al 10)))
                    (list->string
                     (if (< (length bl) 10) bl (take bl 10))))))))

;; Produce a report of a failure.
;; This is potentially usable by modules importing this one.
(define/provide (report-failure failure)
  (let ((suite-label (car failure))
        (test-label (cadr failure))
        (actual (caddr failure))
        (expected (cadddr failure)))
    (format #t "  ~a: ~a\t-> ~a~%  ~a:   ~s~%  ~a: ~s~%"
            suite-label test-label
            (red-text "failed")
            (red-text "actual") actual
            (green-text "expected") expected)
    (cond ((and (string? actual) (string? expected))
           (format #t "Difference: ~a~%" (string-first-diff actual expected)))
          ((and (list? actual) (list? expected))
           (format #t "Difference:~%~a~%" (list-first-diff actual expected))))
    #f))

;; Macro: TEST-SUITE string? . body
;; The body contains a number of (assert-equal actual expected) forms.
;; These are evaluated, and any which fail break out of the suite.
;; The expanded form evaluates to (ngood . nfail)
(define-macro (test-suite label . body)
  `(let* ((ngood 0)
          (inc-good (lambda () (set! ngood (+ ngood 1)))))
     (catch #t
            (λ ()
              (catch 'beastie
                     (λ ()
                       (let* ((suite-label ,label)
                              (failure
                               (call-with-exit
                                (lambda (bail-out)
                                    ,@body
                                    #f))))
                         (if failure
                             (begin
                               (report-failure failure)
                               (signal-failures 1)
                               (cons ngood 1))
                             (let ((label-len (string-length ,label))
                                   (print-width 60)
                                   (s (if (= ngood 1) " " "s")))
                               (if (> label-len print-width)
                                   (format #t "  ~a:~3d test~a OK~%"
                                           (substring ,label 0 print-width) ngood s)
                                   (format #t "  ~a~a:~3d test~a OK~%"
                                           ,label (make-string (- print-width label-len) #\space) ngood s))
                               (cons ngood 0)))))
                     (λ (tag info)
                       ;; INFO is (string? assq?) (from beastie-error/assoc)
                       ;; note: the (stacktrace) isn't useful at this point;
                       ;; it's usefully called in (beastie-error) instead.
                       (let ((msg (car info))
                             (assoc (cadr info)))
                         (eprintf "~a (beastie) in test-suite ~s: ~a~%~a~%"
                                  (red-text "exception") ,label
                                  msg
                                  (if (null? assoc)
                                      ""
                                      assoc))
                         (signal-failures 1)
                         (cons ngood 1)))))
            (λ (tag info)
              ;; The 'error-code in the (owlet) should give _some_
              ;; indication of where this code is, but it may be
              ;; (heuristically?) a level up from the actual problem.
              ;; The 'error-line here doesn't help us: if this is in a
              ;; module, taken from util-extra.c, the line numbers are
              ;; unrelated to the source files.
              (eprintf "~a in test-suite ~a (~s):~%~a~%[caused near ~s]~%"
                       (red-text "exception")
                       ,label tag (apply sprintf info)
                       ((owlet) 'error-code))
              (when (verbosity? trace)
                ;; this is almost never useful!
                ;; In fact, this is _so_ un-useful I strongly suspect I'm using it wrongly.
                (eprintf "stacktrace:~%")
                (display (((owlet) 'stacktrace)))
                (newline))
              (signal-failures 1)
              (cons ngood 1)))))
(module-provide test-suite)

(define (make-accumulator)
  (let ((res '()))
    (λ args
      (if (null? args)
          (reverse res)
          (set! res (cons (car args) res))))))

;; LOAD/TEST-ENV : string? [string?] -> list?
;; Loads a file FN, handling (test-suite...) forms within it.
;; Evaluates to a list (filename ngood nbad nsuites)
;; If the second argument is present, then it names a test-suite which
;; should be run and the others skipped.
(define (load/test-env fn . rest)
  (let ((acc (make-accumulator))
        (outer-test-suite test-suite)
        (outer-load load)
        (outer-module module)
        (*envname* (sprintf "env/~a" fn))) ;see env->string/debug

    (define-macro (test-suite label . body)
      `(cond ((null? rest) (acc (outer-test-suite ,label . ,body)))
             ((string=? (car rest) ,label)
              (acc (outer-test-suite ,label . ,body)))
             (else '())))

    (define (exit/failures) #f)         ;dummy
    (define (signal-failures args) #f)
    (define *current-test-env* (curlet))
    (define (load fn)
      ;; this is the normal load function (ie, that in runtime.scm),
      ;; but we avoid re-loading this file, and we load only in the
      ;; current environment
      (unless (and (string? fn)
                   (string=? fn *THIS-FILE*))
        (outer-load fn *current-test-env*)))

    ;; adjust (module ...) so that it skips any attempt to reload "s7unit.scm"
    (define-macro (module fn . fns)
      (let ((thinned (filter (λ (f)
                               (not (and (string? f)
                                         (string=? f "s7unit.scm")))) ;can't use *THIS-FILE* here
                             (cons fn fns))))
        (if (null? thinned)
            '()
            `(outer-module . ,thinned))))

    (load fn)

    (let ((results (acc)))
      ;; (outer-test-suite) returns (n-passed . 0) if all of the enclosed
      ;; tests passed, and (n-passed . 1) if one of them failed.
      ;; Thus the accumulator returns a list of such pairs, one per test-suite.
      ;; Turn these into a result for this file.
      (list fn
            (apply + (map car results)) ;ngood
            (apply + (map cdr results)) ;number of failing suites
            (length results)))))

;; Run all of the test-suites in the files in the list argument.
;; Return #t if all pass.
(define (run-tests/file-list files)
  (let ((all-results
         (map (λ (fn)
                (cond ((string-index fn #\:)
                       => (λ (colon)
                            (let ((file (substring fn 0 colon))
                                  (test (substring fn (+ colon 1))))
                              (printf "~a (~a)...~%" file test)
                              (load/test-env file test))))
                      (else
                       (printf "~a ...~%" fn)
                       (load/test-env fn))))
              files)))
                                        ;(printf "all-results=~s~%" all-results)
    (let ((n-tests (length all-results))
          (n-good (apply + (map cadr all-results)))
          (n-failed-suites (apply + (map caddr all-results)))
          (n-suites (apply + (map cadddr all-results))))
      (if (= n-failed-suites 0)
          (printf "~%~a file~p  :  ~a tests  :  all ~a test-suites pass~%~a~%"
                  n-tests n-tests n-good n-suites
                  (green-text "OK"))
          (printf "~%~a file~p  :  ~a tests  :  ~a/~a test-suites failed~%~a~%"
                  n-tests n-tests n-good n-failed-suites n-suites
                  (red-text "FAILURES")))
      (= n-failed-suites 0))))

(define *temporary-files* '())
;; Call PROC, with output sent to the given file,
;; and register the file as a temporary one -- see DELETE-TEMPORARY-FILES*!
(define/provide (with-output-to-temporary-file fn proc)
  (with-output-to-file fn proc)
  (set! *temporary-files* (cons fn *temporary-files*))
  fn)
(define (delete-temporary-files*!)
  (for-each delete-file
            *temporary-files*)
  (set! *temporary-files* '()))

(define/provide (file->list-of-lines fn)
  (with-input-from-file fn
    (λ ()
      (let loop ((line (read-line))
                 (res '()))
        (if (eof-object? line)
            (reverse! res)
            (loop (read-line) (cons line res)))))))

;; If this file is itself being run by beastie, then the first
;; string in the *command-line* is this file's name, *THIS-FILE*.
;; In this case, call RUN-TESTS/FILE-LIST on the remaining list of arguments;
;; if there are no arguments, the call it on all of the files
;; test-*.scm.
(define s7unit-is-main?
  (receive (base fn isdir?)
      (split-path (car *command-line*))
    (string=? fn *THIS-FILE*)))

(when s7unit-is-main?
  (define (is-test-file? fn)
    (and (string-prefix? "test-" fn)
         (string-suffix? ".scm" fn)))

  (let ((all-good?
         (run-tests/file-list
          (let ((input-files (cdr *command-line*)))
            (if (null? input-files)
                (sort! (filter is-test-file? (directory->list "."))
                       string<?)
                input-files)))))
    (exit (if all-good? 0 1))))