Christopher Baines
5b0e6397dc
All checks were successful
/ test (push) Successful in 9s
Safsaf is a Guile web framework, written using Claude Code running Claude Opus 4.6, based off of the Guix Data Service, Nar Herder and Guix Build Coordinator codebases.
243 lines
7.6 KiB
Scheme
243 lines
7.6 KiB
Scheme
;; 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))))
|