cbaines/safsaf
cbaines/safsaf
1
Fork 0
Code Issues Pull requests Projects Releases Activity Actions

Initial commit
All checks were successful
/ test (push) Successful in 9s
Details

Browse source 
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.
This commit is contained in:
Christopher Baines 2026-04-13 14:24:19 +03:00
commit 5b0e6397dc
53 changed files with 7427 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

243
tests/support.scm Normal file
View file

@ -0,0 +1,243 @@
;; 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))))