1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
;;; coverage-core.el --- Coverage reporting engine and backend registry -*- lexical-binding: t; coding: utf-8; -*-
;; author: Craig Jennings <c@cjennings.net>
;;; Commentary:
;; Language-agnostic core for diff-aware coverage reporting.
;;
;; Reads an LCOV file, shells to git diff at a selectable scope,
;; intersects the results, and displays a report buffer. Languages
;; plug in via the backend registry (see `cj/coverage-backends').
;;
;; See docs/design/coverage.org for the design rationale.
;;; Code:
(require 'seq)
(defvar cj/coverage-backends nil
"Registry of coverage backends in priority order.
Each entry is a plist with at least :name, :detect, :run, and :lcov-path.
Use `cj/coverage-register-backend' to add or replace an entry.")
(defvar-local cj/coverage-backend nil
"Override: name of the coverage backend to use for the current project.
When nil (the default), resolution runs each registered backend's :detect
function in registration order. Typically set buffer-locally via
`.dir-locals.el' to pin a specific backend.")
(defun cj/coverage-register-backend (backend)
"Register BACKEND, a plist with :name, :detect, :run, :lcov-path.
Appends to `cj/coverage-backends' at the end, or replaces the existing
entry with the same :name in its current position."
(let ((name (plist-get backend :name)))
(if (cj/--coverage-backend-by-name name)
(setq cj/coverage-backends
(mapcar (lambda (b)
(if (eq (plist-get b :name) name) backend b))
cj/coverage-backends))
(setq cj/coverage-backends
(append cj/coverage-backends (list backend))))))
(defun cj/--coverage-backend-by-name (name)
"Return the registered backend whose :name equals NAME, or nil."
(seq-find (lambda (b) (eq name (plist-get b :name)))
cj/coverage-backends))
(defun cj/--coverage-backend-for-project (root &optional override)
"Resolve the coverage backend to use for ROOT.
OVERRIDE, if non-nil, is a backend name symbol (typically the value of
`cj/coverage-backend' from .dir-locals.el). When given, the named
backend is returned regardless of any :detect functions. Signals
`user-error' when OVERRIDE names a backend that isn't registered.
When OVERRIDE is nil, each backend's :detect is called in turn with
ROOT as its sole argument; the first that returns non-nil wins.
Returns the backend plist, or nil when no backend matches."
(cond
(override
(or (cj/--coverage-backend-by-name override)
(user-error
"Unknown coverage backend: %s (registered: %s)"
override
(mapcar (lambda (b) (plist-get b :name)) cj/coverage-backends))))
(t
(seq-find (lambda (backend)
(funcall (plist-get backend :detect) root))
cj/coverage-backends))))
(defun cj/--coverage-parse-lcov (file)
"Parse FILE as LCOV and return a hash table of covered lines.
Keys are source-file paths (strings). Values are hash tables whose
keys are line numbers (integers) that had a hit count greater than
zero. Only the SF, DA, and end_of_record fields are read; other
LCOV fields are ignored. Malformed DA lines are skipped silently.
Signals `user-error' if FILE does not exist."
(unless (file-exists-p file)
(user-error "LCOV file not found: %s" file))
(let ((result (make-hash-table :test 'equal))
(current-file nil)
(current-lines nil))
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(while (not (eobp))
(let ((line (buffer-substring-no-properties
(line-beginning-position) (line-end-position))))
(cond
((string-prefix-p "SF:" line)
(setq current-file (substring line 3))
(setq current-lines (make-hash-table :test 'eql)))
((string-prefix-p "DA:" line)
(when current-lines
(let* ((rest (substring line 3))
(parts (split-string rest ","))
(line-str (car parts))
(hits-str (cadr parts))
(line-num (and line-str (string-match-p "\\`[0-9]+\\'" line-str)
(string-to-number line-str)))
(hits (and hits-str (string-match-p "\\`[0-9]+\\'" hits-str)
(string-to-number hits-str))))
(when (and line-num hits (> hits 0))
(puthash line-num t current-lines)))))
((string= line "end_of_record")
(when current-file
(puthash current-file current-lines result))
(setq current-file nil
current-lines nil))))
(forward-line 1)))
result))
(defconst cj/--coverage-hunk-header-regexp
"^@@ -[0-9]+\\(,[0-9]+\\)? \\+\\([0-9]+\\)\\(,\\([0-9]+\\)\\)? @@"
"Regexp for a git unified-diff hunk header.
Captures new_start (group 2) and new_count (group 4; nil implies 1).")
(defconst cj/--coverage-file-marker-regexp
"^\\+\\+\\+ b/\\(.+\\)$"
"Regexp for the \"+++ b/<path>\" line of a git diff.
Captures the file path (group 1).")
(defun cj/--coverage-parse-diff-output (output)
"Parse OUTPUT, a git unified-diff string, into a hash table.
Keys are file paths (relative to repo root, as git emits them). Values
are hash tables whose keys are line numbers added or modified in the new
version of the file. A file that appears with only deletions maps to an
empty hash table. Malformed hunk headers are skipped silently."
(let ((result (make-hash-table :test 'equal))
(current-lines nil))
(with-temp-buffer
(insert output)
(goto-char (point-min))
(while (not (eobp))
(let ((line (buffer-substring-no-properties
(line-beginning-position) (line-end-position))))
(cond
((string-match cj/--coverage-file-marker-regexp line)
(let ((path (match-string 1 line)))
(setq current-lines (make-hash-table :test 'eql))
(puthash path current-lines result)))
((string-prefix-p "+++ /dev/null" line)
(setq current-lines nil))
((and current-lines
(string-match cj/--coverage-hunk-header-regexp line))
(let* ((new-start (string-to-number (match-string 2 line)))
(count-str (match-string 4 line))
(new-count (if count-str
(string-to-number count-str)
1)))
(when (> new-count 0)
(dotimes (i new-count)
(puthash (+ new-start i) t current-lines)))))))
(forward-line 1)))
result))
(defun cj/--coverage-changed-lines (scope &optional base)
"Return a hash table of files to changed line numbers for SCOPE.
SCOPE is one of the symbols `working-tree', `staged', `branch-vs-main',
or `branch-vs-parent'. For `branch-vs-parent', BASE is the ref to
compare against; if nil, falls back to the tracked upstream @{upstream}.
Signals `user-error' for any other SCOPE."
(let ((cmd (cond
((eq scope 'working-tree)
"git diff HEAD --unified=0")
((eq scope 'staged)
"git diff --cached --unified=0")
((eq scope 'branch-vs-main)
"git diff $(git merge-base HEAD main)..HEAD --unified=0")
((eq scope 'branch-vs-parent)
(format "git diff $(git merge-base HEAD %s)..HEAD --unified=0"
(or base "@{upstream}")))
(t
(user-error "Unknown coverage scope: %s" scope)))))
(cj/--coverage-parse-diff-output (shell-command-to-string cmd))))
(defun cj/--coverage-hash-keys-sorted (table)
"Return a sorted list of TABLE's integer keys."
(let (keys)
(maphash (lambda (k _v) (push k keys)) table)
(sort keys #'<)))
(defun cj/--coverage-intersect (covered changed)
"Combine COVERED (LCOV) with CHANGED (git diff) into per-file records.
COVERED and CHANGED are each hash tables from file path to a hash table
of line numbers (as built by `cj/--coverage-parse-lcov' and
`cj/--coverage-parse-diff-output'). Either may be nil, in which case
the result is an empty list.
Return value is a list of plists, one per entry in CHANGED, sorted by
path:
(:path PATH
:changed-lines LIST-OF-INTS
:covered-lines LIST-OF-INTS ; nil when the file isn't tracked
:uncovered-lines LIST-OF-INTS ; nil when the file isn't tracked
:tracked BOOL)
A file that appears in CHANGED but not in COVERED is marked as
`:tracked nil'; coverage data is unavailable for it, so no lines
can be classified as covered or uncovered."
(unless (and covered changed)
(setq covered (or covered (make-hash-table :test 'equal)))
(setq changed (or changed (make-hash-table :test 'equal))))
(let (paths records)
(maphash (lambda (path _) (push path paths)) changed)
(setq paths (sort paths #'string<))
(dolist (path paths)
(let* ((changed-set (gethash path changed))
(changed-lines (cj/--coverage-hash-keys-sorted changed-set))
(covered-set (gethash path covered))
(tracked (and covered-set t))
covered-lines
uncovered-lines)
(when tracked
(dolist (line changed-lines)
(if (gethash line covered-set)
(push line covered-lines)
(push line uncovered-lines)))
(setq covered-lines (nreverse covered-lines)
uncovered-lines (nreverse uncovered-lines)))
(push (list :path path
:changed-lines changed-lines
:covered-lines covered-lines
:uncovered-lines uncovered-lines
:tracked tracked)
records)))
(nreverse records)))
(provide 'coverage-core)
;;; coverage-core.el ends here
|
