From 571eb0764fe001bc9bae7a18eeaae5d6e7dcdab0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 6 Mar 2022 11:53:40 +0100
Subject: Test runner only output coverage of "our" modules.

---
 scripts/all-modules.scm     | 33 +++++++++++++++++++++++++++++++++
 scripts/use2dot/gen-use.scm | 32 ++++----------------------------
 tests/run-tests.scm         | 36 +++++++++++++++++++++++++++++++++---
 3 files changed, 70 insertions(+), 31 deletions(-)
 create mode 100644 scripts/all-modules.scm

diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm
new file mode 100644
index 00000000..41f35393
--- /dev/null
+++ b/scripts/all-modules.scm
@@ -0,0 +1,33 @@
+(define-module (all-modules)
+  :use-module (ice-9 regex)
+  :use-module (srfi srfi-1)
+  :use-module (ice-9 ftw)
+  :use-module (ice-9 match)
+  :export (all-modules-under-directory))
+
+(define (all-modules-under-directory dir)
+  "Returns two values, all scm files in dir, and all top
+level modules in those files"
+
+  (define re (make-regexp "\\.scm$"))
+
+  (define files '())
+
+  (ftw dir (lambda (filename statinfo flag)
+             (cond ((and (eq? flag 'regular)
+                         (regexp-exec re filename))
+                    => (lambda (m)
+                         (set! files (cons filename files))
+                         #t
+                         ))
+                   (else #t))))
+
+
+  (values files
+          (filter identity
+                  (map (lambda (file)
+                         (match (call-with-input-file file read)
+                           (('define-module (module ...) _ ...)
+                            module)
+                           (_ #f)))
+                       files))))
diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm
index e02be9bd..6c621fdd 100755
--- a/scripts/use2dot/gen-use.scm
+++ b/scripts/use2dot/gen-use.scm
@@ -2,43 +2,19 @@
 !#
 
 (add-to-load-path (dirname (current-filename)))
+(add-to-load-path (dirname (dirname (current-filename))))
 
 (use-modules ((scripts frisk) :select (make-frisker edge-type edge-up
                               edge-down))
              (srfi srfi-1)
-             (ice-9 ftw)
-             (ice-9 regex)
-             (ice-9 match)
              ((graphviz) :prefix gv.)
+             (all-modules)
              )
 
 (define scan (make-frisker `(default-module . (calp main))))
 
-(define re (make-regexp "\\.scm$"))
-
-(define lst '())
-
-(ftw "module" (lambda (filename statinfo flag)
-                (cond ((and (eq? flag 'regular)
-                            (regexp-exec re filename))
-                       => (lambda (m)
-                            (set! lst (cons filename lst))
-                            #t
-                            ))
-                      (else #t))))
-
-
-
-(define files lst)
-
-(define our-modules
-  (filter identity
-          (map (lambda (file)
-                 (match (call-with-input-file file read)
-                        (('define-module (module ...) _ ...)
-                         module)
-                        (_ #f)))
-               files)))
+(define-values (files our-modules)
+  (all-modules-under-directory "module"))
 
 (define graph (gv.digraph "G"))
 (gv.setv graph "color" "blue")
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index 43f3ccf8..ee0b596e 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -118,7 +118,8 @@ exec $GUILE --debug -s "$0" "$@"
              ((hnh util) :select (for awhen))
              ;; datetime introduces the reader extensions for datetimes,
              ;; which leaks into the sandboxes below.
-             (datetime))
+             (datetime)
+             ((srfi srfi-1) :select (take-while drop)))
 
 (define files
   (scandir here
@@ -206,10 +207,39 @@ exec $GUILE --debug -s "$0" "$@"
                   (format (current-error-port)
                           "Test unexpectedly crashed [~a]: ~s~%" err args))) )))))))
 
+(use-modules (hnh util path))
+(add-to-load-path (path-append (dirname here) "scripts"))
+
+(define-values (module-files module-names)
+  ((@ (all-modules) all-modules-under-directory)
+   (path-append (dirname here) "module")))
+
 
 (call-with-values run-with-coverage
   (lambda (data _)
-    (call-with-output-file "lcov.info"
-      (lambda (port) (coverage-data->lcov data port)))))
+
+    (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))
+
+    (let ((better-data
+            ((@@ (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)))
+      (call-with-output-file "lcov.info"
+        (lambda (port) (coverage-data->lcov better-data port))))))
 
 (test-end "tests")
-- 
cgit v1.2.3