safsaf/tests/support.scm

;; Safsaf, a Guile web framework
;; Copyright (C) 2026  Christopher Baines <mail@cbaines.net>

;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU Lesser 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this program.  If not, see
;; <https://www.gnu.org/licenses/>.

(define-module (tests support)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:export (is
            test
            suite
            suite-thunk
            define-suite
            test-runner*
            test?
            suite?
            suite-thunk?
            run-tests))

;;;
;;; Minimal SRFI-269 implementation for Guile.
;;;
;;; Three definition primitives — is, test, suite — construct first-class
;;; entities (alists) and deliver them to a pluggable test runner via
;;; message passing.  Definition is separated from execution: the runner
;;; decides when and how to run things.
;;;

;;; --- Parameter ---

(define test-runner* (make-parameter #f))

;;; --- Predicates ---

(define (test? obj)
  (and (pair? obj)
       (assq 'test/body-thunk obj)
       (assq 'test/description obj)
       #t))

(define (suite? obj)
  (and (pair? obj)
       (assq 'suite/body-thunk obj)
       (assq 'suite/description obj)
       #t))

(define (suite-thunk? obj)
  (procedure? obj))

;;; --- is ---

(define-syntax is
  (lambda (x)
    (syntax-case x ()
      ;; Predicate form: (is (pred arg ...))
      ((_ (pred arg ...))
       (with-syntax ((src (datum->syntax x (syntax-source x))))
         #'(%run-assert
            (lambda () (pred arg ...))
            '(pred arg ...)
            'src
            (lambda () (list arg ...)))))
      ;; Simple form: (is expr)
      ((_ expr)
       (with-syntax ((src (datum->syntax x (syntax-source x))))
         #'(%run-assert
            (lambda () expr)
            'expr
            'src
            #f))))))

(define (%run-assert body-thunk body-datum source args-thunk)
  (let* ((entity `((assert/body-thunk . ,body-thunk)
                   (assert/body . ,body-datum)
                   (assert/location . ,source)
                   ,@(if args-thunk
                         `((assert/args-thunk . ,args-thunk))
                         '()))))
    ((test-runner*)
     `((type . runner/run-assert)
       (assert . ,entity)))))

;;; --- test ---

(define-syntax test
  (syntax-rules (quote)
    ((_ desc (quote metadata) meta body ...)
     (%load-test desc 'meta (lambda () body ... (values))))
    ((_ desc body ...)
     (%load-test desc '() (lambda () body ... (values))))))

(define (%load-test description metadata body-thunk)
  ((test-runner*)
   `((type . runner/load-test)
     (test . ((test/body-thunk . ,body-thunk)
              (test/description . ,description)
              (test/metadata . ,metadata))))))

;;; --- suite ---

(define-syntax suite
  (syntax-rules (quote)
    ((_ desc (quote metadata) meta body ...)
     (%load-suite desc 'meta (lambda () body ... (values))))
    ((_ desc body ...)
     (%load-suite desc '() (lambda () body ... (values))))))

(define (%load-suite description metadata body-thunk)
  ((test-runner*)
   `((type . runner/load-suite)
     (suite . ((suite/body-thunk . ,body-thunk)
               (suite/description . ,description)
               (suite/metadata . ,metadata))))))

;;; --- suite-thunk ---

(define-syntax suite-thunk
  (syntax-rules (quote)
    ((_ desc (quote metadata) meta body ...)
     (lambda ()
       (%load-suite desc 'meta (lambda () body ... (values)))))
    ((_ desc body ...)
     (lambda ()
       (%load-suite desc '() (lambda () body ... (values)))))))

;;; --- define-suite ---

(define-syntax define-suite
  (syntax-rules (quote)
    ((_ name (quote metadata) meta body ...)
     (define name
       (suite-thunk (symbol->string 'name) (quote metadata) meta body ...)))
    ((_ name body ...)
     (define name
       (suite-thunk (symbol->string 'name) body ...)))))


;;;
;;; Simple immediate-execution test runner.
;;;

(define %depth 0)
(define %pass-count 0)
(define %fail-count 0)
(define %error-count 0)
(define %test-failed? #f)

(define (indent)
  (make-string (* 2 %depth) #\space))

(define (format-location loc)
  "Return a string like \"file.scm:42\" from a source location alist,
or #f if location info is unavailable."
  (and loc
       (let ((file (assq-ref loc 'filename))
             (line (assq-ref loc 'line)))
         (and file line
              (format #f "~a:~a" file (+ line 1))))))

(define (simple-test-runner message)
  (let ((type (assq-ref message 'type)))
    (case type

      ((runner/load-suite)
       (let* ((s (assq-ref message 'suite))
              (desc (assq-ref s 'suite/description))
              (body (assq-ref s 'suite/body-thunk)))
         (format #t "~a~a~%" (indent) desc)
         (set! %depth (+ %depth 1))
         (body)
         (set! %depth (- %depth 1))))

      ((runner/load-test)
       (let* ((t (assq-ref message 'test))
              (desc (assq-ref t 'test/description))
              (body (assq-ref t 'test/body-thunk)))
         (set! %test-failed? #f)
         (with-exception-handler
             (lambda (exn)
               (set! %error-count (+ %error-count 1))
               (format #t "~aERROR ~a~%" (indent) desc)
               (format #t "~a  ~a~%" (indent) exn))
             (lambda ()
               (body)
               (if %test-failed?
                   (begin
                     (set! %fail-count (+ %fail-count 1))
                     (format #t "~aFAIL  ~a~%" (indent) desc))
                   (begin
                     (set! %pass-count (+ %pass-count 1))
                     (format #t "~aok    ~a~%" (indent) desc))))
           #:unwind? #t)))

      ((runner/run-assert)
       (let* ((a (assq-ref message 'assert))
              (body-thunk (assq-ref a 'assert/body-thunk))
              (body-datum (assq-ref a 'assert/body))
              (loc (assq-ref a 'assert/location)))
         (let ((result (body-thunk)))
           (unless result
             (set! %test-failed? #t)
             (format #t "~a  FAIL: ~s" (indent) body-datum)
             (let ((loc-str (format-location loc)))
               (when loc-str
                 (format #t " at ~a" loc-str)))
             (newline)
             ;; Show evaluated arguments for predicate assertions.
             (let ((args-thunk (assq-ref a 'assert/args-thunk)))
               (when args-thunk
                 (with-exception-handler
                     (lambda (_) #f)
                     (lambda ()
                       (let ((args (args-thunk)))
			 (format #t "~a    args: ~s~%" (indent) args)))
                   #:unwind? #t))))
           result))))))

(define (run-tests thunk)
  "Set up the simple test runner, call THUNK (typically a suite-thunk),
print a summary, and exit with 0 on success or 1 on failure."
  (set! %depth 0)
  (set! %pass-count 0)
  (set! %fail-count 0)
  (set! %error-count 0)
  (parameterize ((test-runner* simple-test-runner))
    (thunk))
  (newline)
  (let ((total (+ %pass-count %fail-count %error-count)))
    (format #t "~a passed, ~a failed, ~a errors (of ~a)~%"
            %pass-count %fail-count %error-count total)
    (exit (if (and (zero? %fail-count) (zero? %error-count)) 0 1))))