Automatically mark all definitions as covered.

Guile's coverage system often missed those. Explicitly adding coverage
information make percentage go up!

2 files changed, 88 insertions, 79 deletions

diff --git a/testrunner.scm b/testrunner.scm
index 48ebc3df..2f6ca943 100755
--- a/testrunner.scm
+++ b/testrunner.scm
@@ -32,6 +32,7 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
              (hnh test testrunner)
              (hnh test util)
              ((hnh util io) :select (displayln))
+             (hnh module-introspection all-modules)
              (crypto)
              (ice-9 popen)
              (ice-9 rdelim)
@@ -41,6 +42,15 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 
 
 
+(define exemption-rxs
+  (list
+   ;; All definitions are ignored, since they quite often are missed
+   ;; (and don't really "run")
+   "\\(define(-(\\w|-)+[*]?)?\\s"
+   "read-hash-extend"))
+
+
+
 (define-syntax-rule (begin-thread forms ...)
   (let ((thread (make-thread (lambda () forms ...))))
     (thread-start! thread)
@@ -279,22 +289,16 @@ Flags:
                     lines: (map (lambda (l) (cons l 1)) lines))))))
        (read port)))
 
-
-;;; TODO replace this with native Guile variant
-(define (all-files-under-dir dir)
-  (let ((pipe (open-pipe*
-               OPEN_READ
-               "find" dir
-               "-type" "f"
-               "-name" "*.scm"
-               "-exec" "realpath" "--zero" "{}" ";")))
-    (let loop ((done '()))
-      (let ((line (read-delimited "\0" pipe)))
-        (if (eof-object? line)
-            (begin
-              (close-pipe pipe)
-              done)
-            (loop (cons line done)))))))
+;; Return the line numbers of all lines which
+;; contain an instance of the given regex
+(define (matching-lines rx port)
+  (let loop ((lino 1) (hit '()))
+    (let ((line (read-line port)))
+      (if (eof-object? line)
+          hit
+          (if (regexp-exec rx line)
+              (loop (1+ lino) (cons lino hit))
+              (loop (1+ lino) hit))))))
 
 
 (define (main args)
@@ -349,7 +353,23 @@ Flags:
   (unless (null? outdated-extra)
     (format #t "The following files have changed since their coverage")
     (format #t "exceptions were written. Please review:~%")
-    (for-each (compose displayln yellow) outdated-extra))
+    (for-each (lambda (line)
+                (displayln
+                 (yellow
+                  (format #f "~a, expected SHA256: ~a"
+                          (filename (cdr line))
+                          (car line)))))
+              outdated-extra))
+
+  (define coverage-exemptions
+    (let ((rx (make-regexp (string-join exemption-rxs "|" 'infix))))
+      (map (lambda (filename)
+             (coverage-info
+              filename: (realpath filename)
+              lines: (map (lambda (l) (cons l 1))
+                          (call-with-input-file filename
+                            (lambda (port) (matching-lines rx port))))))
+           (all-files-under-directory "module" ".scm"))))
 
   ((@ (hnh util exceptions) warnings-are-errors) #t)
 
@@ -364,16 +384,31 @@ Flags:
                                         (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))))))
 
+          (define expected-files (concatenate (cons (map cdr extra-coverage)
+                                                    (stack->list results))))
 
           (define uncovered-files
             (lset-difference! string=?
-             (all-files-under-dir "module/")
-             (map filename merged-coverages)))
+             (map realpath (all-files-under-directory "module" ".scm"))
+             (map filename expected-files)))
+
+          (define merged-coverages
+            (map (lambda (group) (reduce merge-coverage #f (cdr group)))
+                 (group-by filename
+                           (append
+                            expected-files
+                            ;; Remove totally uncovered files from the
+                            ;; excepmption list. Otherwise they would
+                            ;; (accidentally) get a really high coverage
+                            ;; percentage, instead of 0%.
+
+                            ;; TODO possibly also remove vendored files,
+                            ;; Locking them to 1/1 lines covered (line 2).
+                            (remove (lambda (entry) (member (filename entry)
+                                                       uncovered-files))
+                                    coverage-exemptions)))))
+
 
           (unless (null? merged-coverages)
             (with-output-to-file coverage
diff --git a/tests/unit/coverage-supplement.scm b/tests/unit/coverage-supplement.scm
index b8cea855..9b4e5a0e 100644
--- a/tests/unit/coverage-supplement.scm
+++ b/tests/unit/coverage-supplement.scm
@@ -8,111 +8,74 @@
 ;;; - The sha256-sum of that file
 ;;; - Any number of lines which should be marked as covered.
 (
- ("module/hnh/util/atomic-queue.scm"
-  "40c0e0feb77392e3eb1f6ab6136cc116aeeded6030eea7db6688901df5ed021d"
-  1 18)
- ("module/hnh/util/atomic-stack.scm"
-  "147b45d2216c378c35d5c3ed0228be393b6c287f2a5515802928040f2087378e"
-  1 13 29)
  ("module/hnh/util/type.scm"
   "f670542b9b404125224fd4c702be99e2c1c3fd55d862b18228e8772264ef3189"
-  1                                      ; Module declaration
   12 34 44 46                            ; Macros
   53)                                    ; false? == not
- ;; File is not tested at all, since it's mearly a "header" file.
- ;; TODO possibly actually test extension loading, since it should
- ;; fail gracefully when library is not available.
- ("module/graphviz.scm"
-  "5ff20a55098973fcc8552cd897e779eaf01dc3d4909f8d23be47d317987d8e95"
-  18 82 84)
+
  ("module/base64.scm"
   "4614855f6cfedc20041e7094989e817f2c2c5ef85fb5f8322d915101c0aab53c"
-  1 ; module declaration
-  23 24 25 26 27 29 ; internal lookup table, used by everything so tested implicitly
+  23 24 25 26 27 ; internal lookup table, used by everything so tested implicitly
   53 54 55 56 ; internal helper function, tested implictly
  )
+
  ("module/text/util.scm"
   "271a5f7740aa6e378e7fda2da4725171dc50a2e4a790e9529fceed19a747e775"
-  5                                     ; (Module declaration
   52                                    ; else "keyword" apparently missed
   )
+
  ("module/vcomponent/duration.scm"
   "c83a2750964c2362af5043f33b435a792f62007d847f543e78a8f2550757e010"
   ;; Unreachable code, but fail faster
   113 114 115
   118 119 120 121
   )
- ("module/calp.scm"
-  "873a191bc7122e59e3d60fb0f075dfa73fd8cc5ae0f3cb51932b24a0497ceeb1"
-  1 ; Modudule declaration
-  5 ; Version number (global variables are missed by the coverage)
-  )
+
  ("module/crypto.scm"
   "9e157f5b53e923e7925b0e53118a4789b55712120427b73c4c3c9561e2c48718"
-  1 ; Module declaration
   8 ; dynamic link
-  10 11 12 13 14 ; constants
   16 17 18 19 ; primitive sha256 procedure
   )
+
  ("module/datetime.scm"
   "67eb46283a4097e8400322ab6434518a2455ca630e163238b5839c2bf25c9ac7"
-  1
-  159 160 161 162 163 164 165 ; week day declarations
-  ;; function declarations
-  189 223 238 389 909
-  965 966 974
-  987 992 1011 1025
-  1231
-  1239 1280
-  923 924 925 ; read-hash-extend
-  ;; aliases
-  958 959 960
-  1029 1031 1032 1034 1036 1037 1039 1041 1042 1044 1046 1047
-  1049 1051 1052 1054 1056 1057 1059 1061 1062 1064 1065 1067 1068
-  ;; other
   204
   252 ; Would depend on local timezone
   491 ; somehow not counted
+  966
   )
 
  ("module/datetime/zic.scm"
   "2a8ac0fae3c88227b05a5978bff3e114745ea146e07a2751df67d16c1e8218f5"
-  13 ; module declaration
   66 ; syntax-rules
-  171 223 ; function declaration
   )
 
- ("module/datetime/timespec.scm"
-  "9feb7a7a09d9942d72c6b14b9f230e7711a73ca518ec2dc209775354203d856b"
-  6 ; module declaration
-  )
 
  ("module/hnh/util.scm"
   "3f0bf90a45d6eecce1248b7509e1b050e5cadbe92b279fe5ef082c18baf3e6ca"
-  1
   72 73 74 ; conditional import
-  77 ; syntax rules not covered:w
-  289 ; != definition
-  333 488 568 ; syntax rules
+  77 ; syntax rules not covered
+  333 568 ; syntax rules
   )
 
- ("module/srfi/srfi-41/util.scm"
-  "adb832b17f7ffe7c070fa3845f65283e850b14a07499d22715e16111f59ad88e"
-  1)
+ ("module/calp/translation.scm"
+  "b7c0a82e1c109c339cf83438f39b6fc63219b51a3ad3ee35d58e70fb6a24c5c9"
+  9 ; bindtextdomain
+  )
 
+
 
  ;; this file simply exports other things. There's nothing to test
  ("module/vcomponent.scm"
   "b1c58b3beb6f170d3c9f7d603b27231ccf696897736113095b446f437721a9e1"
   2)
 
+ ;; get-terminal-size is basically impossible to test
+ ("module/vulgar/info.scm"
+  "f9f30fd2709a5614b986c697e089c36c7d5d8cd3824e6d4e2bac042d5c2c23e6"
+  2)
 
- ("module/calp/translation.scm"
-  "b7c0a82e1c109c339cf83438f39b6fc63219b51a3ad3ee35d58e70fb6a24c5c9"
-  1
-  9 ; bindtextdomain
-  22 ; G_ function
-  )
+
 
 ;;; Vendored files, and therefore shouldn't be tested
 
@@ -123,4 +86,15 @@
  ("module/sxml/html.scm"
   "b4ffca46c9c723f6828e32d8798f1bbc89c2bfcb6f1368906b2d4bdef11951db"
   2)
+
+ ("module/web/http.scm"
+  "50637403dd63d6d1390903cdea17abf26ad09bcf7f95b9492298da30ebcb03ff"
+  2)
+
+ ;; File is not tested at all, since it's mearly a "header" file.
+ ;; TODO possibly actually test extension loading, since it should
+ ;; fail gracefully when library is not available.
+ ("module/graphviz.scm"
+  "5ff20a55098973fcc8552cd897e779eaf01dc3d4909f8d23be47d317987d8e95"
+  2)
 )