From d8a52af2520d14035fc3a36a7aa3569f9856380a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 8 Oct 2023 11:29:21 +0200
Subject: Further rewrite of testrunner.

Move many of the atomic procedures into proper libraries.
---
 testrunner.scm | 191 ++++++++++++++++++++++++++++++++-------------------------
 1 file changed, 108 insertions(+), 83 deletions(-)

(limited to 'testrunner.scm')

diff --git a/testrunner.scm b/testrunner.scm
index c3fa0ae3..267e3c17 100755
--- a/testrunner.scm
+++ b/testrunner.scm
@@ -1,11 +1,11 @@
 #!/usr/bin/env bash
 # -*- mode: scheme; geiser-scheme-implementation: guile -*-
 
-make calp unit-test-deps
+make calp
+make unit-test-deps
 
 root=$(dirname "$(realpath "$0")")
-eval "$(env __PRINT_ENVIRONMENT=1 ${root}/calp)"
-
+eval "$(env __PRINT_ENVIRONMENT=1 "${root}/calp")"
 
 exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 !#
@@ -19,26 +19,25 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
              (srfi srfi-18)
              (srfi srfi-64)
              (srfi srfi-71)
-             ((hnh util) :select (->> for group-by))
+             (srfi srfi-111)
+             ((rnrs io ports) :select (get-bytevector-all))
+             ((hnh util) :select (-> ->> for group-by))
              (hnh util path)
              (hnh util type)
-             ((hnh util lens) :select (modify cdr* car* compose-lenses))
              (hnh util object)
              (hnh util coverage)
+             (hnh util atomic)
+             (hnh util atomic-stack)
+             (hnh util atomic-queue)
+             (hnh test testrunner)
+             ((hnh util io) :select (displayln))
+             (crypto)
              (ice-9 getopt-long)
              (ice-9 control)
              (ice-9 format))
 
 
 
-(define-syntax with-mutex
-  (syntax-rules ()
-    ((_ mutex body ...)
-     (dynamic-wind
-       (lambda () (mutex-lock! mutex))
-       (lambda () body ...)
-       (lambda () (mutex-unlock! mutex))))))
-
 (define-syntax-rule (begin-thread forms ...)
   (let ((thread (make-thread (lambda () forms ...))))
     (thread-start! thread)
@@ -66,34 +65,16 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 
 (define current-filename (make-parameter #f))
 
-(define (construct-test-runner)
-  (define runner (test-runner-null))
-  (test-runner-aux-value!
-   runner
-   `((thread-name . ,(thread-name (current-thread)))))
-  #;
-  (test-runner-on-test-begin! runner
-    (lambda (runner)
-      (test-runner-aux-value! runner #t)))
-  (test-runner-on-test-end! runner
-    (lambda (runner)
-      (case (test-result-kind runner)
-        ((pass)
-         (if (getenv "VERBOSE")
-             (println (format #f "~a SUCCEED ~a"
-                              (current-filename)
-                              (test-runner-test-name runner)))
-             (display #\#)))
-        ((fail)
-         (println (format #f "~a FAIL ~a"
-                          (current-filename)
-                          (test-runner-test-name runner))))
-        ((xpass xfail skip)
-         (println (format #f "~a ~a ~a"
-                          (current-filename)
-                          (test-result-kind runner)
-                          (test-runner-test-name runner)))))))
-  runner)
+(define (test-runner-name runner)
+ (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)
+                      (write p)
+                      ))))))
 
 
 (define (test-runner-processed runner)
@@ -114,19 +95,20 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
                 (else
                  (string-join (test-runner-group-path runner) " → ")))))
 
-(define runners '())
-(define runner-mutex (make-mutex))
+
+
+(define runners (atomic-stack))
+
 (sigaction SIGINT
-(lambda _
+  (lambda _
     (display
-    (string-join (map test-runner-test-description runners) "\n"))))
-
+     (string-join (map test-runner-test-description (stack->list runners))
+                  "\n"))))
 
 (define-type (job)
   (jobname type: string?)
   (job-thunk type: thunk?))
 
-
 (define* (maybe-with-code-coverage thunk key: (coverage? #f))
   (if coverage?
       (with-code-coverage
@@ -141,15 +123,13 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
         (lambda ()
           (parameterize ((current-filename (basename entry)))
             (test-begin entry)
-            (with-mutex runner-mutex
-              (set! runners (cons (test-runner-get) runners)))
+            (push! (test-runner-get) runners)
             (let ((coverage module-names
                             (maybe-with-code-coverage
                              (lambda () (load entry))
                              coverage?: coverage?)))
               (let ((tested-files (map module->source-file module-names)))
                 (test-end entry)
-                (println (format #f "Completed ~a" entry))
                 (if coverage
                     (let ((lcov-data
                            (call-with-output-string
@@ -162,28 +142,20 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 
 
 (define* (make-work-pool jobs key: (thread-count 1))
-  (define job-pool jobs)
-  (define pool-mutex (make-mutex))
-
-  (define results (list))
-  (define results-mutex (make-mutex))
+  (define job-pool (atomic-stack))
+  (define results (atomic-stack))
+  (for-each (lambda (job) (push! job job-pool)) jobs)
 
   (define (pool-worker)
     (call/ec
      (lambda (return)
        (while #t
-         (let ((job (with-mutex pool-mutex
-                      (if (null? job-pool)
-                          (return #f)
-                          (let ((job (car job-pool)))
-                            (set! job-pool (cdr job-pool))
-                            job)))))
+         (let ((job (pop! job-pool)))
+           (unless job (return #f))
            (catch #t
-             (lambda ()
-               (let ((result ((job-thunk job))))
-                 (with-mutex results-mutex
-                   (set! results (cons result results)))))
+             (lambda () (push! ((job-thunk job)) results))
              (lambda args
+               ;; TODO indicate FATAL ERROR
                (println (format #f "Job [~a] failed: ~s"
                                 (jobname job)
                                 ;; TODO better error formatting
@@ -218,6 +190,7 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
     (nice (value #t))
     (threads (value #t))
     (coverage (value optional))
+    (coverage-supplement (value #t))
     ))
 
 (define help "
@@ -249,18 +222,31 @@ Flags:
 --coverage [output-filename]
   Generate code coverage data, this causes the tests to be quite
   a bit slower.
+--coverage-supplement supplement-file
 ")
 
 
+
+(define (read-coverage-info port)
+  (map (lambda (entry)
+         (call-with-values (lambda () (apply values entry))
+           (lambda (filename checksum . lines)
+             (cons checksum
+                   (coverage-info
+                    filename: (realpath filename)
+                    lines: (map (lambda (l) (cons l 1)) lines))))))
+       (read port)))
+
+
+
 (define (main args)
   (define options (getopt-long args option-spec))
 
   (when (option-ref options 'help #f)
-    (display help)
     (exit 0))
 
-  (when (option-ref options 'verbose #f)
-    (setenv "VERBOSE" "1"))
+  (when (option-ref options 'verbose (getenv "VERBOSE"))
+    (verbose? #t))
 
   (define test-files
     (cond ((option-ref options 'suite #f)
@@ -271,7 +257,9 @@ Flags:
 
   (nice (string->number (option-ref options 'nice "10")))
 
-  (test-runner-factory construct-test-runner)
+  (define error-queue (atomic-queue))
+
+  (test-runner-factory (construct-test-runner print error-queue))
 
   (define coverage
     (let ((cov (option-ref options 'coverage #f)))
@@ -279,21 +267,58 @@ Flags:
             (cov "coverage.info")
             (else #f))))
 
+  ;; Guile's coverage system sometimes miss some definitions.
+  ;; Add these here so the output gets green.
+  ;; However, always start by attempting to add more tests to fill
+  ;; in the coverage.
+  (define-values (extra-coverage outdated-extra)
+    (cond ((option-ref options 'coverage-supplement #f)
+           => (lambda (supplement-file)
+                (partition
+                 (lambda (pair)
+                   (let ((checksum coverage (car+cdr pair)))
+                     (-> (call-with-input-file (filename coverage)
+                           get-bytevector-all)
+                         sha256
+                         checksum->string
+                         (string=? checksum))))
+                 (call-with-input-file supplement-file read-coverage-info))))
+          (else (values '() '()))))
+
+  (unless (null? outdated-extra)
+    (format #t "The following files have changed since their coverage")
+    (format #t "exceptions were written. Please review:~%")
+    (for-each displayln outdated-extra))
+
   ((@ (hnh util exceptions) warnings-are-errors) #t)
 
   (if (option-ref options 'list #f)
       (format #t "Gathered the following tests:~%~y~%" test-files)
-      (let ((results (thread-join!
-                      (make-work-pool
-                       (prepare-jobs test-files coverage?: coverage)
-                       thread-count: (string->number
-                                      (option-ref options 'threads "1"))))))
-        (define merged-coverages
-          (map (lambda (group) (reduce merge-coverage #f (cdr group)))
-               (group-by filename (concatenate results))))
-
-        (unless (null? merged-coverages)
-          (with-output-to-file coverage
-            (lambda ()
-              (display "TN:") (newline)
-              (for-each output-coverage merged-coverages)))))))
+      (begin
+        (test-begin "Universe")
+        (let ((results (thread-join!
+                        (make-work-pool
+                         (prepare-jobs test-files coverage?: coverage)
+                         thread-count: (string->number
+                                        (option-ref options 'threads "1"))))))
+
+          (test-end "Universe")
+          (define merged-coverages
+            (map (lambda (group) (reduce merge-coverage #f (cdr group)))
+                 (group-by filename (concatenate (cons (map cdr extra-coverage)
+                                                       (stack->list results))))))
+
+
+          (unless (null? merged-coverages)
+            (with-output-to-file coverage
+              (lambda ()
+                (display "TN:") (newline)
+                (for-each output-coverage merged-coverages))))
+
+          (display "== Gathered errors ==\n")
+          (let loop ()
+            (cond ((dequeue! error-queue)
+                   => (lambda (entry)
+                        (display entry)
+                        (newline)
+                        (loop)))))))))
-- 
cgit v1.2.3