#!/usr/bin/env bash # -*- mode: scheme; geiser-scheme-implementation: guile -*- here=$(dirname $(realpath $0)) . "$(dirname "$here")/env" if [ "$DEBUG" = '' ]; then exec $GUILE -s "$0" "$@" else exec $GUILE --debug -s "$0" "$@" fi !# (format #t "current-filename = ~s~%" (current-filename)) (define here (dirname (current-filename))) (use-modules (hnh util path)) (use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-88) (hnh util) ((hnh util io) :select (call-with-tmpfile)) (ice-9 ftw) (ice-9 format) (ice-9 pretty-print) (ice-9 getopt-long) (ice-9 match) (ice-9 regex) ((ice-9 popen) :select (open-pipe* close-pipe)) ((ice-9 rdelim) :select (read-string)) (system vm coverage) ((hnh module-introspection all-modules) :select (fs-find)) ) (define (µs x) (* x #e1e6)) (define (transform-time-of-day tod) (+ (* (µs 1) (car tod)) (cdr tod))) (define verbose? (make-parameter #f)) (define (escaped sequence string) (format #f "\x1b[~am~a\x1b[m" sequence string)) (define (green s) (escaped 32 s)) (define (red s) (escaped 31 s)) (define (yellow s) (escaped 33 s)) (define (bold s) (escaped 1 s)) (define (make-indent depth) (make-string (* 2 depth) #\space)) (define (string-replace-head s1 s2) (string-replace s1 s2 0 (string-length s2))) (define (diff s1 s2) (let ((filename1 (call-with-tmpfile (lambda (p f) (display s1 p) f))) (filename2 (call-with-tmpfile (lambda (p f) (display s2 p) f)))) (let ((pipe (open-pipe* OPEN_READ ;; "git" "diff" "--no-index" "diff" filename1 filename2))) (begin1 (begin (read-string pipe)) (close-pipe pipe))))) (define (pp form indent prefix-1) (let ((prefix (make-string (+ (string-length indent) (string-length prefix-1)) #\space))) (string-replace-head (with-output-to-string (lambda () (pretty-print form per-line-prefix: prefix width: (- 79 (string-length indent))))) (string-append indent prefix-1)))) (define (construct-test-runner) (define runner (test-runner-null)) (define depth 0) ;; end of individual test case (test-runner-on-test-begin! runner (lambda (runner) (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) (test-runner-on-test-end! runner (lambda (runner) (when (verbose?) (display (make-indent depth))) (case (test-result-kind runner) ((pass) (display (green "X"))) ((fail) (display (red "E"))) ((xpass) (display (yellow "X"))) ((xfail) (display (yellow "E"))) ((skip) (display (yellow "-")))) (when (or (verbose?) (eq? 'fail (test-result-kind))) (format #t " ~a~%" (cond ((test-runner-test-name runner) (negate string-null?) => identity) ((test-result-ref runner 'expected-value) => (lambda (p) (with-output-to-string (lambda () (display (bold "[SOURCE]: ")) (truncated-print p width: 60)))))))) (when (eq? 'fail (test-result-kind)) (cond ((test-result-ref runner 'actual-error) => (lambda (err) (if (and (list? err) (= 5 (length err))) (let ((err (list-ref err 0)) (proc (list-ref err 1)) (fmt (list-ref err 2)) (args (list-ref err 3))) (format #t "~a~a in ~a: ~?~%" (make-indent (1+ depth)) err proc fmt args)) (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) (else (let ((unknown-expected (gensym)) (unknown-actual (gensym))) (let ((expected (test-result-ref runner 'expected-value unknown-expected)) (actual (test-result-ref runner 'actual-value unknown-actual))) (let ((indent (make-indent (1+ depth)))) (if (eq? expected unknown-expected) (format #t "~aAssertion failed~%" indent) (begin (display (pp expected indent "Expected: ")) (display (pp actual indent "Received: ")) (let ((d (diff (pp expected "" "") (pp actual "" "")))) (display (string-join (map (lambda (line) (string-append indent "|" line)) (string-split d #\newline)) "\n" 'suffix)))))))))) (format #t "~aNear ~a:~a~%" (make-indent (1+ depth)) (test-result-ref runner 'source-file) (test-result-ref runner 'source-line)) (pretty-print (test-result-ref runner 'source-form) (current-output-port) per-line-prefix: (string-append (make-indent (1+ depth)) "> ") )) (let ((start (test-runner-aux-value runner)) (end (transform-time-of-day (gettimeofday)))) (when (< (µs 1) (- end start)) (format #t "~%Slow test: ~s, took ~a~%" (test-runner-test-name runner) (exact->inexact (/ (- end start) (µs 1))) ))))) ;; on start of group (test-runner-on-group-begin! runner ;; count is number of #f (lambda (runner name count) (if (<= depth 1) (format #t "~a ~a ~a~%" (make-string 10 #\=) name (make-string 10 #\=)) (when (verbose?) (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) (set! depth (1+ depth)))) (test-runner-on-group-end! runner (lambda (runner) (set! depth (1- depth)) (when (<= depth 1) (newline)))) ;; after everything else is done (test-runner-on-final! runner (lambda (runner) (format #t "Guile version ~a~%~%" (version)) (format #t "pass: ~a~%" (test-runner-pass-count runner)) (format #t "fail: ~a~%" (test-runner-fail-count runner)) (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) )) runner) (test-runner-factory construct-test-runner) (define (rework-coverage data) (define-values (module-files module-names) ((@ (all-modules) all-modules-under-directory) (path-append (dirname here) "module"))) (define to-drop (1+ (length (take-while (lambda (p) (not (string=? p "module"))) (path-split (car module-files)))))) (define (drop-components path-list) (drop path-list to-drop)) (define target-ht (make-hash-table)) (define source-ht ((@@ (system vm coverage) data-file->line-counts) data)) (for-each (lambda (path) (cond ((hash-ref source-ht path #f) => (lambda (value) (hash-set! target-ht path value))))) (map (compose path-join drop-components path-split) module-files)) ((@@ (system vm coverage) %make-coverage-data) ((@@ (system vm coverage) data-ip-counts) data) ((@@ (system vm coverage) data-sources) data) ((@@ (system vm coverage) data-file->procedures) data) target-ht)) (define option-spec '((skip (value #t)) (only (value #t)) (verbose (single-char #\v)) (coverage (value optional)))) (define options (getopt-long (command-line) option-spec)) (define coverage-dest (option-ref options 'coverage #f)) (when (option-ref options 'verbose #f) (verbose? #t)) (define re (make-regexp "\\.scm$")) (define files (map car (filter (match-lambda ((filename _ 'regular) (regexp-exec re filename)) (_ #f)) (fs-find (path-append here "test"))))) ;; (format #t "Running on:~%~y~%" files) ((@ (hnh util exceptions) warnings-are-errors) #t) (define finalizer (if coverage-dest (lambda (thunk) (define-values (coverage _) (with-code-coverage thunk)) (let ((limited-coverage (rework-coverage coverage))) (call-with-output-file coverage-dest (lambda (port) (coverage-data->lcov limited-coverage port)))) (format #t "Wrote coverage data to ~a~%" coverage-dest)) (lambda (thunk) (thunk)) )) ;;; Catch/print-trace should intercept thrown exceptions, print them prettily with a stack trace, and then continue #; (define (catch/print-trace proc) (catch #t proc (case-lambda ((err from msg args data) (test-assert (format #f "~a in ~a: ~?" err from msg args) #f)) (args (test-assert (format #f "~a (~s)" f args) #f))))) (define (catch/print-trace proc) (proc)) (test-begin "suite") (define onlies (let %loop ((args (command-line)) (onlies '())) (define* (loop args key: only) (if only (%loop args (cons only onlies)) (%loop args onlies))) (if (null? args) onlies (cond ((string-match "^--skip(=.*)?$" (car args)) => (lambda (m) (cond ((match:substring m 1) => (lambda (s) (format #t "Skipping ~s~%" s) (test-skip s) (loop (cdr args)))) (else (format #t "Skipping ~s~%" (cadr args)) (test-skip (cadr args)) (loop (cddr args)))))) ((string-match "^--only(=.*)?$" (car args)) => (lambda (m) (cond ((match:substring m 1) => (lambda (s) (loop (cdr args) only: s))) (else (loop (cddr args) only: (cadr args)))))) (else (loop (cdr args))))))) (unless (null? onlies) (set! files (map (lambda (x) (path-append "test" x)) ;; reverse only until I have built a dependency graph for tests (reverse onlies)))) (finalizer (lambda () (for-each (lambda (f) (catch/print-trace (lambda () (test-group f (load f))))) files))) (test-end "suite") (newline)