source: trunk/source/library/cover.lisp @ 14044

Last change on this file since 14044 was 14044, checked in by gz, 9 years ago

support for reporting code coverage of acode, needs more testing

File size: 41.3 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2008-2009 Clozure Associates
4;;;   This file is part of Clozure CL.
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; Code coverage reporting facility, originally inspired by SBCL's sb-cover API.
18
19(in-package :ccl)
20
21(export '(*compile-code-coverage*
22          report-coverage
23          reset-coverage
24          clear-coverage
25          save-coverage-in-file
26          restore-coverage-from-file
27
28          save-coverage
29          restore-coverage
30          combine-coverage
31          read-coverage-from-file
32          write-coverage-to-file
33
34          coverage-statistics
35          coverage-source-file
36          coverage-expressions-total
37          coverage-expressions-entered
38          coverage-expressions-covered
39          coverage-unreached-branches
40          coverage-code-forms-total
41          coverage-code-forms-covered
42          coverage-functions-total
43          coverage-functions-fully-covered
44          coverage-functions-partly-covered
45          coverage-functions-not-entered
46
47          without-compiling-code-coverage))
48
49(defconstant $no-style 0)
50(defconstant $not-executed-style 1)
51(defconstant $totally-covered-style 2)
52(defconstant $partially-covered-style 3)
53
54(defparameter *file-coverage* ())
55(defparameter *coverage-subnotes* (make-hash-table :test #'eq))
56(defparameter *emitted-code-notes* (make-hash-table :test #'eq))
57(defparameter *entry-code-notes* (make-hash-table :test #'eq))
58(defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
59
60(defparameter *coverage-acode-queue* nil)
61
62(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
63  alist)
64
65;; Wrapper in case we ever want to do dwim on raw alists
66(defun coverage-state-alist (coverage)
67  (etypecase coverage
68    (coverage-state (%coverage-state-alist coverage))))
69
70
71(defun file-coverage-file (entry)
72  (car entry))
73
74(defun file-coverage-functions (entry)
75  (cadr entry))
76
77(defun file-coverage-toplevel-functions (entry)
78  (cddr entry))
79
80(defun coverage-subnotes (note) ;; reversed parent chain
81  (gethash note *coverage-subnotes*))
82
83(defun emitted-code-note-p (note)
84  (gethash note *emitted-code-notes*))
85
86(defun entry-code-note-p (note)
87  (gethash note *entry-code-notes*))
88
89(defun code-note-acode-string (note)
90  (gethash note *code-note-acode-strings*))
91
92(defun map-function-coverage (lfun fn &optional refs)
93  (let ((refs (cons lfun refs)))
94    (declare (dynamic-extent refs))
95    (lfunloop for imm in lfun
96              when (code-note-p imm)
97              do (funcall fn imm)
98              when (and (functionp imm)
99                        (not (memq imm refs)))
100              do (map-function-coverage imm fn refs))))
101
102(defun get-function-coverage (fn refs acode)
103  (let ((entry (function-entry-code-note fn))
104        (refs (cons fn refs))
105        (acode (or (%function-acode-string fn) acode)))
106    (declare (dynamic-extent refs))
107    (when entry
108      (assert (eq fn (gethash entry *entry-code-notes* fn)))
109      (setf (gethash entry *entry-code-notes*) fn)
110      (when acode
111        (setf (gethash entry *code-note-acode-strings*) acode)))
112    (nconc
113     (and entry (list fn))
114     (lfunloop for imm in fn
115       when (code-note-p imm)
116       do (progn
117            (setf (gethash imm *emitted-code-notes*) t)
118            (when acode
119              (setf (gethash imm *code-note-acode-strings*) acode)))
120       when (and (functionp imm)
121                 (not (memq imm refs)))
122       nconc (get-function-coverage imm refs acode)))))
123
124(defun get-coverage ()
125  (setq *file-coverage* nil)
126  (clrhash *coverage-subnotes*)
127  (clrhash *emitted-code-notes*)
128  (clrhash *entry-code-notes*)
129  (clrhash *code-note-acode-strings*)
130  (loop for data in *code-covered-functions*
131        when (consp data)
132        do (destructuring-bind (file . toplevel-functions) data
133             (push (list* file
134                          ;; Duplicates are possible if you have multiple instances of
135                          ;; (load-time-value (foo)) where (foo) returns an lfun.
136                          ;; CL-PPCRE does that.
137                          (delete-duplicates
138                           (loop for fn across toplevel-functions
139                                nconc (get-function-coverage fn nil nil)))
140                          toplevel-functions)
141                   *file-coverage*)))
142  ;; Now get subnotes, including un-emitted ones.
143  (loop for note being the hash-key of *emitted-code-notes*
144        do (loop for n = note then parent as parent = (code-note-parent-note n)
145                 while parent
146                 do (pushnew n (gethash parent *coverage-subnotes*))
147                 until (emitted-code-note-p parent)))
148  (let ((hash (make-hash-table :test #'eq)))
149    ;; distribute entry acode to the toplevel source note it belongs to.
150    (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn)
151      as acode = (code-note-acode-string entry)
152      as sn = (entry-note-unambiguous-source entry)
153      as toplevel-sn = (function-source-form-note fn)
154      do (when sn
155           (assert toplevel-sn)
156           (let* ((pos (source-note-end-pos sn))
157                  (cell (assq acode (gethash toplevel-sn hash))))
158             (if cell
159               (setf (cdr cell) (max (cdr cell) pos))
160               (push (cons acode pos) (gethash toplevel-sn hash))))))
161    (setf *coverage-acode-queue*
162          (sort (loop for sn being the hash-key of hash using (hash-value alist)
163                  collect (cons (source-note-end-pos sn)
164                                (mapcar #'car (sort alist #'< :key #'cdr))))
165                #'< :key #'car))))
166
167#+debug
168(defun show-notes (note)
169  (when (functionp note)
170    (setq note (function-entry-code-note note)))
171  (labels ((show (note indent label)
172             (dotimes (i indent) (write-char #\space))
173             (format t "~a ~a" label note)
174             (unless (emitted-code-note-p note)
175               (format t " [Not Emitted]"))
176             (when (entry-code-note-p note)
177               (format t " (Entry to ~s)" (entry-code-note-p note)))
178             (when (code-note-acode-range note)
179               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
180                 (format t " [acode ~a:~a]" s e)))
181             (format t "~%")
182             (when (code-note-p note)
183               (loop with subindent = (+ indent 3)
184                     for sub in (coverage-subnotes note) as i upfrom 1
185                     do (show sub subindent (format nil "~a~d." label i))))))
186    (show note 0 "")))
187
188(defun assoc-by-filename (path alist)
189  (let* ((true-path (probe-file path)))
190    (find-if #'(lambda (data)
191                 (or (equalp (car data) path)
192                     (and true-path (equalp (probe-file (car data)) true-path))))
193             alist)))
194
195(defun covered-functions-for-file (path)
196  (cdr (assoc-by-filename path *code-covered-functions*)))
197
198(defun clear-coverage ()
199  "Clear all files from the coverage database. The files will be re-entered
200into the database when the FASL files (produced by compiling with
201CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the
202image."
203  (setq *code-covered-functions* nil))
204
205(defun reset-function-coverage (lfun)
206  (map-function-coverage lfun #'(lambda (note)
207                                  (setf (code-note-code-coverage note) nil))))
208
209(defun reset-coverage ()
210  "Reset all coverage data back to the `Not executed` state."
211  (loop for data in *code-covered-functions*
212        do (typecase data
213             (cons ;; (source-file . functions)
214                (loop for fn across (cdr data)
215                      do (reset-function-coverage fn)))
216             (function (reset-function-coverage data)))))
217
218;; Name used for consistency checking across file save/restore
219(defun function-covered-name (fn)
220  (let ((name (function-name fn)))
221    (and (symbolp name)
222         (symbol-package name)
223         name)))
224 
225
226(defun coverage-mismatch (why &rest args)
227  ;; Throw to somebody who knows what file we're working on.
228  (throw 'coverage-mismatch (cons why args)))
229
230(defmacro with-coverage-mismatch-catch ((saved-file) &body body)
231  `(let ((file ,saved-file)
232         (err (catch 'coverage-mismatch ,@body nil)))
233     (when err
234       (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))
235
236
237;; (name . #(i1 i2 ...)) where in is either an index or (index . subfncoverage).
238(defun save-function-coverage (fn &optional (refs ()))
239  (let ((refs (cons fn refs)))
240    (declare (dynamic-extent refs))
241    (cons (function-covered-name fn)
242          (lfunloop for imm in fn as i upfrom 0
243                    when (and (code-note-p imm)
244                              (code-note-code-coverage imm))
245                    collect i into list
246                    when (and (functionp imm) (not (memq imm refs)))
247                    collect (cons i (save-function-coverage imm refs)) into list
248                    finally (return (and list (coerce list 'vector)))))))
249
250(defun copy-function-coverage (fn-data)
251  (cons (car fn-data)
252        (and (cdr fn-data)
253             (map 'vector #'(lambda (imm-data)
254                              (if (consp imm-data)
255                                (cons (car imm-data)
256                                      (copy-function-coverage (cdr imm-data)))
257                                imm-data))
258                  (cdr fn-data)))))
259
260(defun restore-function-coverage (fn saved-fn-data &optional (refs ()))
261  (let* ((refs (cons fn refs))
262         (saved-name (car saved-fn-data))
263         (saved-imms (cdr saved-fn-data))
264         (nimms (length saved-imms))
265         (n 0))
266    (declare (dynamic-extent refs))
267    (unless (equalp saved-name (function-covered-name fn))
268      (coverage-mismatch "had function ~s now have ~s" saved-name fn))
269    (lfunloop for imm in fn as i upfrom 0
270              when (code-note-p imm)
271              do (let* ((next (and (< n nimms) (aref saved-imms n))))
272                   (when (if (consp next) (<= (car next) i) (and next (< next i)))
273                     (coverage-mismatch "in ~s" fn))
274                   (when (setf (code-note-code-coverage imm)
275                               (and (eql next i) 'restored))
276                     (incf n)))
277              when (and (functionp imm) (not (memq imm refs)))
278              do (let* ((next (and (< n nimms) (aref saved-imms n))))
279                   (unless (and (consp next) (eql (car next) i))
280                     (coverage-mismatch "in ~s" fn))
281                   (restore-function-coverage imm (cdr next) refs)
282                   (incf n)))))
283
284
285(defun add-function-coverage (fn-data new-fn-data)
286  (let* ((fn-name (car fn-data))
287         (imms (cdr fn-data))
288         (new-fn-name (car new-fn-data))
289         (new-imms (cdr new-fn-data)))
290    (flet ((kar (x) (if (consp x) (%car x) x)))
291      (declare (inline kar))
292      (unless (equalp fn-name new-fn-name)
293        (coverage-mismatch "function ~s vs. ~s" fn-name new-fn-name))
294      (when new-imms
295        (loop for new across new-imms
296              as old = (find (kar new) imms :key #'kar)
297              if (and (null old) (fixnump new))
298                collect new into extras
299              else do (unless (eql old new)
300                        (if (and (consp new) (consp old))
301                          (add-function-coverage (cdr old) (cdr new))
302                          (coverage-mismatch "in function ~s" fn-name)))
303              finally (when extras
304                        (setf (cdr fn-data)
305                              (sort (concatenate 'vector imms extras) #'< :key #'kar))))))
306    fn-data))
307
308
309(defun save-coverage ()
310  "Returns a snapshot of the current coverage state"
311  (make-coverage-state
312   :alist (loop for data in *code-covered-functions*
313                when (consp data)
314                  collect (cons (car data)
315                                (map 'vector #'save-function-coverage (cdr data))))))
316
317(defun combine-coverage (coverage-states)
318  (let ((result nil))
319    (map nil
320         (lambda (coverage-state)
321           (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state)
322                 for result-fns = (cdr (assoc-by-filename saved-file result))
323                 do (with-coverage-mismatch-catch (saved-file)
324                      (cond ((null result-fns)
325                             (push (cons saved-file
326                                         (map 'vector #'copy-function-coverage saved-fns))
327                                   result))
328                            ((not (eql (length result-fns) (length saved-fns)))
329                             (coverage-mismatch "different function counts"))
330                            (t 
331                             (loop for result-fn across result-fns
332                                   for saved-fn across saved-fns
333                                   do (add-function-coverage result-fn saved-fn)))))))
334         coverage-states)
335    (make-coverage-state :alist (nreverse result))))
336
337
338(defun restore-coverage (coverage-state)
339  "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE."
340  (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state)
341        for fns = (covered-functions-for-file saved-file)
342        do (with-coverage-mismatch-catch (saved-file)
343             (cond ((null fns)
344                    (warn "Couldn't restore saved coverage for ~s, no matching file present"
345                          saved-file))
346                   ((not (eql (length fns) (length saved-fns)))
347                    (coverage-mismatch "had ~s functions, now have ~s"
348                                       (length saved-fns) (length fns)))
349                   (t 
350                    (map nil #'restore-function-coverage fns saved-fns))))))
351
352(defvar *loading-coverage*)
353
354(defun write-coverage-to-file (coverage pathname)
355  "Write the coverage state COVERAGE in the file designated by PATHNAME"
356  (with-open-file (stream pathname
357                          :direction :output
358                          :if-exists :supersede
359                          :if-does-not-exist :create)
360    (with-standard-io-syntax
361      (let ((*package* (pkg-arg "CCL")))
362        (format stream "(in-package :ccl)~%~s~%"
363                `(setq *loading-coverage* ',(coverage-state-alist coverage)))))
364    (values)))
365 
366(defun read-coverage-from-file (pathname)
367  " Return the coverage state saved in the file.  Doesn't affect the current coverage state."
368  (let ((*package* (pkg-arg "CCL"))
369        (*loading-coverage* :none))
370    (load pathname)
371    (when (eq *loading-coverage* :none)
372      (error "~s doesn't seem to be a saved coverage file" pathname))
373    (make-coverage-state :alist *loading-coverage*)))
374
375(defun save-coverage-in-file (pathname)
376  "Save the current coverage state in the file designed by PATHNAME"
377  (write-coverage-to-file (save-coverage) pathname))
378
379(defun restore-coverage-from-file (pathname)
380  "Set the current coverage state from the file designed by PATHNAME"
381  (restore-coverage (read-coverage-from-file pathname)))
382
383(defun common-coverage-directory ()
384  (let* ((host :unknown)
385         (rev-dir ()))
386    (loop for data in *code-covered-functions*
387       when (consp data)
388       do (let ((file (probe-file (car data))))
389            (when file
390              (cond ((eq host :unknown)
391                     (setq host (pathname-host file)
392                           rev-dir (reverse (pathname-directory file))))
393                    ((not (equalp host (pathname-host file)))
394                     (return-from common-coverage-directory nil))
395                    (t
396                     (let* ((path (pathname-directory file))
397                            (dir-len (length rev-dir))
398                            (len (length path)))
399                       (if (< len dir-len)
400                         (setq rev-dir (nthcdr (- dir-len len) rev-dir))
401                         (setq path (subseq path 0 dir-len)))
402                       (loop for pp on (reverse path) until (equalp pp rev-dir)
403                          do (pop rev-dir))))))))
404    (unless (eq host :unknown)
405      (make-pathname :host host :directory (reverse rev-dir)))))
406
407
408(defstruct (coverage-statistics (:conc-name "COVERAGE-"))
409  source-file
410  expressions-total
411  expressions-entered
412  expressions-covered
413  unreached-branches
414  code-forms-total
415  code-forms-covered
416  functions-total
417  functions-fully-covered
418  functions-partly-covered
419  functions-not-entered)
420
421(defun coverage-statistics ()
422  (let* ((*file-coverage* nil)
423         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
424         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
425         (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
426    (get-coverage)
427    (loop for coverage in *file-coverage*
428          as stats = (make-coverage-statistics :source-file (file-coverage-file coverage))
429          do (map nil (lambda (fn)
430                        (let ((note (function-entry-code-note fn)))
431                          (when note (precompute-note-coverage note))))
432                  (file-coverage-toplevel-functions coverage))
433          do (destructuring-bind (total entered %entered covered %covered)
434                 (count-covered-sexps coverage)
435               (declare (ignore %entered %covered))
436               (setf (coverage-expressions-total stats) total)
437               (setf (coverage-expressions-entered stats) entered)
438               (setf (coverage-expressions-covered stats) covered))
439          do (let ((count (count-unreached-branches coverage)))
440               (setf (coverage-unreached-branches stats) count))
441          do (destructuring-bind (total covered %covered) (count-covered-aexps coverage)
442               (declare (ignore %covered))
443               (setf (coverage-code-forms-total stats) total)
444               (setf (coverage-code-forms-covered stats) covered))
445          do (destructuring-bind (total fully %fully partly %partly never %never)
446                 (count-covered-entry-notes coverage)
447               (declare (ignore %fully %partly %never))
448               (setf (coverage-functions-total stats) total)
449               (setf (coverage-functions-fully-covered stats) fully)
450               (setf (coverage-functions-partly-covered stats) partly)
451               (setf (coverage-functions-not-entered stats) never))
452          collect stats)))
453
454
455(defun report-coverage (output-file &key (external-format :default) (statistics t) (html t))
456  "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE
457and, in the same directory, one html file for each instrumented source file that has been
458loaded in the current session.
459The external format of the source files can be specified with the EXTERNAL-FORMAT parameter.
460If :STATISTICS is non-nil, a CSV file is generated with a table.  If
461:STATISTICS is a filename, that file is used, else 'statistics.csv' is
462written to the output directory.
463"
464  (let* ((paths)
465         (directory (make-pathname :name nil :type nil :defaults output-file))
466         (coverage-dir (common-coverage-directory))
467         (*file-coverage* nil)
468         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
469         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
470         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
471         (index-file (and html (merge-pathnames output-file "index.html")))
472         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
473                                                              (pathnamep statistics))
474                                                        (merge-pathnames statistics "statistics.csv")
475                                                        "statistics.csv")
476                                                      output-file))))
477    (get-coverage)
478    (ensure-directories-exist directory)
479    (loop for coverage in *file-coverage*
480      as file = (or (probe-file (file-coverage-file coverage))
481                    (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
482                           nil))
483      do (when file
484           (let* ((src-name (enough-namestring file coverage-dir))
485                  (html-name (substitute
486                              #\_ #\: (substitute
487                                       #\_ #\. (substitute
488                                                #\_ #\/ (namestring-unquote src-name))))))
489             (when html
490               (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
491                                       :direction :output
492                                       :if-exists :supersede
493                                       :if-does-not-exist :create)
494                 (report-file-coverage index-file coverage stream external-format)))
495             (push (list* src-name html-name coverage) paths))))
496    (when (null paths)
497      (error "No code coverage data available"))
498    (setq paths (sort paths #'(lambda (path1 path2)
499                                (let* ((f1 (car path1))
500                                       (f2 (car path2)))
501                                  (or (string< (directory-namestring f1)
502                                               (directory-namestring f2))
503                                      (and (equal (pathname-directory f1)
504                                                  (pathname-directory f2))
505                                           (string< (file-namestring f1)
506                                                    (file-namestring f2))))))))
507    (if html
508      (with-open-file (html-stream index-file
509                                   :direction :output
510                                   :if-exists :supersede
511                                   :if-does-not-exist :create)
512        (if stats-file
513          (with-open-file (stats-stream stats-file
514                                        :direction :output
515                                        :if-exists :supersede
516                                        :if-does-not-exist :create)
517            (report-coverage-to-streams paths html-stream stats-stream))
518          (report-coverage-to-streams paths html-stream nil)))
519      (if stats-file
520        (with-open-file (stats-stream stats-file
521                                      :direction :output
522                                      :if-exists :supersede
523                                      :if-does-not-exist :create)
524          (report-coverage-to-streams paths nil stats-stream))
525        (error "One of :HTML or :STATISTICS must be non-nil")))
526    (values index-file stats-file)))
527
528(defun report-coverage-to-streams (paths html-stream stats-stream)
529  (when html-stream (write-coverage-styles html-stream))
530  (unless paths
531    (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
532    (when html-stream (format html-stream "<h3>No code coverage data found.</h3>~%"))
533    (when stats-stream (format stats-stream "No code coverage data found.~%"))
534    (return-from report-coverage-to-streams))
535  (when html-stream (format html-stream "<table class='summary'>"))
536  (coverage-stats-head html-stream stats-stream)
537  (loop for prev = nil then src-name
538        for (src-name report-name . coverage) in paths
539        for even = nil then (not even)
540        do (when (or (null prev)
541                     (not (equal (pathname-directory (pathname src-name))
542                                 (pathname-directory (pathname prev)))))
543             (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
544               (when html-stream (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir))
545               (when stats-stream (format stats-stream "~a~%" dir))))
546        do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
547  (when html-stream (format html-stream "</table>")))
548
549(defun precompute-note-coverage (note &optional refs)
550  (when note
551    (let ((subnotes (coverage-subnotes note))
552          (refs (cons note refs)))
553      (declare (dynamic-extent refs))
554      (loop for sub in subnotes
555            when (member sub refs)
556            do (break "Circularity!!")
557            unless (member sub refs)
558            do (precompute-note-coverage sub refs))
559      (when (and (or (not (emitted-code-note-p note))
560                     (code-note-code-coverage note))
561                 (loop for sub in subnotes
562                       always (or (eq 'full (code-note-code-coverage sub))
563                                  (entry-code-note-p sub))))
564        (setf (code-note-code-coverage note) 'full)))))
565
566
567(defun style-for-coverage (coverage)
568  (case coverage
569    ((full) $totally-covered-style)
570    ((nil) $not-executed-style)
571    (t $partially-covered-style)))
572 
573(defun fill-with-text-style (coverage location-note styles)
574  (fill styles (style-for-coverage coverage)
575        :start (source-note-start-pos location-note)
576        :end (source-note-end-pos location-note)))
577
578(defun update-text-styles (note styles)
579  (let ((source (code-note-source-note note)))
580    (when source
581      (fill-with-text-style (code-note-code-coverage note) source styles))
582    (unless (and (emitted-code-note-p note)
583                 (memq (code-note-code-coverage note) '(nil full))
584                 ;; If not a source note, descend in case have some subnotes
585                 ;; that can be shown
586                 source)
587      (loop for sub in (coverage-subnotes note)
588            unless (entry-code-note-p sub)
589            do (update-text-styles sub styles)))))
590
591(defun entry-note-unambiguous-source (entry-note)
592  ;; Return the nearest containing source note provided it can be done unambiguously.
593  (loop for n = entry-note then parent until (code-note-source-note n)
594        as parent = (code-note-parent-note n)
595        do (unless (and parent
596                        (labels ((no-other-entry-subnotes (n refs)
597                                   (let ((subs (coverage-subnotes n))
598                                         (refs (cons n refs)))
599                                     (declare (dynamic-extent refs))
600                                     (loop for sub in subs
601                                           always (or (memq sub refs)
602                                                      (eq sub entry-note)
603                                                      (and (not (entry-code-note-p sub))
604                                                           (no-other-entry-subnotes sub refs)))))))
605                          (no-other-entry-subnotes parent ())))
606             (return nil))
607        finally (return (code-note-source-note n))))
608
609(defun colorize-source-note (note styles)
610  ;; Change coverage flag to 'full if all subforms are covered.
611  (precompute-note-coverage note)
612  ;; Now actually change text styles, from outside in.
613  ;; But first, a special kludge:
614  ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function "
615  ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner
616  ;; function got executed.  However, suppose have a macro "(setq-fun foo (x) x)" that
617  ;; expanded into the above, there isn't a clear way to show the distinction between
618  ;; just referencing the inner fn and executing it.  In practice, the colorization
619  ;; based on the inner function is more interesting -- consider for example DEFUN,
620  ;; nobody cares whether the defun form itself got executed.
621  ;; So when showing the colorization of an inner function, we usurp the whole nearest source
622  ;; form, provided it can be done unambiguously.
623  (let ((n (entry-note-unambiguous-source note)))
624    (when n
625      (fill-with-text-style (code-note-code-coverage note) n styles)))
626  (update-text-styles note styles))
627
628(defun function-source-form-note (fn)
629  ;; Find the outermost source form containing the fn.
630  (loop with sn = nil
631        for n = (function-entry-code-note fn) then (code-note-parent-note n)
632        do (when (null n) (return nil))
633        do (when (setq sn (code-note-source-note n))
634             (loop for s = (source-note-source sn) while (source-note-p s)
635                   do (setq sn s))
636             (return sn))))
637
638(defun colorize-acode (fn acode-styles)
639  (let* ((acode (%function-acode-string fn))
640         (note (function-entry-code-note fn))
641         (range (and note (code-note-acode-range note))))
642    (when (and acode range)
643      (let ((styles (or (gethash acode acode-styles)
644                        (setf (gethash acode acode-styles)
645                              (make-array (length acode)
646                                          :initial-element $no-style
647                                          :element-type '(unsigned-byte 2))))))
648        (iterate update ((note note))
649          (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note))
650            (when (and start
651                       (setq start (position-if-not #'whitespacep acode :start start :end end)))
652              (fill styles (style-for-coverage (code-note-code-coverage note))
653                    :start start
654                    :end end)))
655          (loop for sub in (coverage-subnotes note)
656            unless (entry-code-note-p sub)
657            do (update sub)))))))
658
659(defun colorize-function (fn styles acode-styles &optional refs)
660  (let* ((note (function-entry-code-note fn))
661         (source (function-source-form-note fn))
662         (refs (cons fn refs)))
663    (declare (dynamic-extent refs))
664    ;; Colorize the body of the function
665    (when note
666      (colorize-source-note note styles)
667      (colorize-acode fn acode-styles))
668    ;; And now any subfunction references
669    (lfunloop for imm in fn
670              when (and (functionp imm)
671                        (not (memq imm refs))
672                        ;; Make sure this fn is in the source we're currently looking at.
673                        ;; It might not be, if it is referenced via (load-time-value (foo))
674                        ;; where (foo) returns an lfun from some different source entirely.
675                        ;; CL-PPCRE does that.
676                        (or (null source)
677                            (eq source (function-source-form-note imm))
678                            #+debug (progn
679                                      (warn "Ignoring ref to ~s from ~s" imm fn)
680                                      nil)))
681              do (colorize-function imm styles acode-styles refs))))
682
683(defun report-file-coverage (index-file coverage html-stream external-format)
684  "Print a code coverage report of FILE into the stream HTML-STREAM."
685  (format html-stream "<html><head>")
686  (write-coverage-styles html-stream)
687  (format html-stream "</head><body>")
688  (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format)
689                   (let ((string (make-string (file-length s))))
690                     (read-sequence string s)
691                     string)))
692         (styles (make-array (length source)
693                             :initial-element $no-style
694                             :element-type '(unsigned-byte 2)))
695         (acode-styles (make-hash-table :test #'eq)))
696    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage))
697    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
698    (format html-stream "</body></html>")))
699
700(defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source)
701  (let ((*print-case* :downcase))
702    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
703            (native-translated-namestring (make-pathname :name (pathname-name index-file)
704                                                         :type (pathname-type index-file)))
705            (file-coverage-file coverage))
706    (format html-stream "<table class='summary'>")
707    (coverage-stats-head html-stream nil)
708    (coverage-stats-data html-stream nil coverage)
709    (format html-stream "</table>")
710
711    (format html-stream "<div class='key'><b>Key</b><br />~%")
712    (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
713    (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
714    (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
715    (format html-stream "</div><p></p>~%")
716
717    ;; Output source intertwined with acode
718    (iterate output ((start 0) (line 0))
719      (format html-stream "<div class='source'><code>")
720      (let ((next (car *coverage-acode-queue*)))
721        (multiple-value-bind (end last-line)
722                             (output-styled html-stream source styles
723                                            :start start
724                                            :line line
725                                            :limit (car next))
726          (format html-stream "</code></div>~%")
727          (when (and next end (<= (car next) end))
728            (destructuring-bind (pos . strings) next
729              (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~
730                                   <div class='acode' id='a~:*~d'><code>" pos)
731              (loop for acode in strings as styles = (gethash acode acode-styles)
732                do (assert styles)
733                do (output-styled html-stream acode styles)
734                do (fresh-line html-stream))
735              (format html-stream "</code></div><hr/>~%"))
736            (pop *coverage-acode-queue*)
737            (output (1+ end) last-line)))))))
738
739(defun output-styled (html-stream source styles &key (start 0) line limit)
740  (let ((last-style $no-style)
741        (col 0)
742        (line line))
743    (labels ((outch (char)
744               (if (eql char #\Tab)
745                 (dotimes (i (- 8 (mod col 8)))
746                   (incf col)
747                   (write-string " " html-stream))
748                 (progn
749                   (incf col)
750                   (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe
751                     (write-char char html-stream)
752                     (format html-stream "&#~D;" (char-code char))))))
753             (start-line ()
754               (when line
755                 (incf line)
756                 (format html-stream "<span class='line'>~A</span>" line))
757               (write-char #\space html-stream)
758               (setq col 0))
759             (set-style (new)
760               (unless (eq last-style new)
761                 (unless (eq last-style $no-style) (format html-stream "</span>"))
762                 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new))
763                 (setq last-style new)))
764             (end-line ()
765               (set-style $no-style)
766               (format html-stream "~%")))
767      (declare (inline outch start-line end-line))
768      (unless limit (setq limit (length source)))
769      (start-line)
770      (loop
771        for pos from start below (length source)
772        as char = (aref source pos) as style = (aref styles pos)
773        do (set-style style)
774        do (case char
775             ((#\Newline)
776              (end-line)
777              (when (<= limit pos)
778                (return (values pos line)))
779              (start-line))
780             (t
781              (outch char)))
782        finally (end-line)))))
783
784
785(defun coverage-stats-head (html-stream stats-stream)
786  (when html-stream
787    (format html-stream "<tr class='head-row'><td></td>")
788    (format html-stream "<td class='main-head' colspan='5'>Expressions</td>")
789    (format html-stream "<td class='main-head' colspan='1'>Branches</td>")
790    (format html-stream "<td class='main-head' colspan='3'>Code Forms</td>")
791    (format html-stream "<td class='main-head' colspan='7'>Functions</td></tr>")
792    (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
793            '("Source file"
794              ;; Expressions
795              "Total" "Entered" "% entered" "Fully covered" "% fully covered"
796              ;; Branches
797              "total unreached"
798              ;; Code forms
799              "Total" "Covered" "% covered"
800              ;; Functions
801              "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
802  (when stats-stream
803    (format stats-stream "~{~a~^,~}"
804            `("Source file"
805              "Expressions Total" "Expressions Entered" "% Expressions Entered"
806              "Unreached Branches"
807              "Code Forms Total" "Code Forms Covered" "% Code Forms Covered"
808              "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
809              "Functions Partly Covered" "% Functions Partly Covered"
810              "Functions Not Entered" "% Functions Not Entered"))))
811
812(defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name)
813  (when html-stream
814    (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
815    (if report-name
816      (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name)
817      (format html-stream "<td class='text-cell'>~a</td>" (file-coverage-file coverage))))
818  (when stats-stream
819    (format stats-stream "~a," (file-coverage-file coverage)))
820
821  (let ((exp-counts (count-covered-sexps coverage)))
822    (when html-stream
823      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
824    (when stats-stream
825      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
826
827  (let ((count (count-unreached-branches coverage)))
828    (when html-stream
829      (format html-stream "<td>~:[-~;~:*~a~]</td>" count))
830    (when stats-stream
831      (format stats-stream "~:[~;~:*~a~]," count)))
832
833  (let ((exp-counts (count-covered-aexps coverage)))
834    (when html-stream
835      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
836    (when stats-stream
837      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
838
839  (destructuring-bind (total . counts) (count-covered-entry-notes coverage)
840    (when html-stream
841      (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts))
842    (when stats-stream
843      (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
844
845(defun map-coverage-entry-notes (coverage fn)
846  (map nil #'(lambda (function)
847                 (let ((note (function-entry-code-note function)))
848                   (when (and note
849                              ;; Ignore toplevel functions created by the compiler.
850                              (or (code-note-source-note note)
851                                  (code-note-parent-note note)))
852                     (funcall fn note))))
853       (file-coverage-functions coverage)))
854
855
856(defun count-covered-entry-notes (coverage)
857  (let ((fully 0) (partly 0) (never 0) (total 0))
858    (map-coverage-entry-notes
859     coverage
860     #'(lambda (note)
861         (incf total)
862         (case (code-note-code-coverage note)
863           ((full) (incf fully))
864           ((nil) (incf never))
865           (t (incf partly)))))
866    (if (> total 0)
867        (list total
868              fully (* 100.0 (/ fully total))
869              partly (* 100.0 (/ partly total))
870              never (* 100.0 (/ never total)))
871        '(0 0 -- 0 -- 0 --))))
872
873(defun count-covered-aexps (coverage)
874  (let ((covered 0) (total 0))
875    (map-coverage-entry-notes
876     coverage
877     (lambda (note)
878       (labels ((rec (note)
879                  (when (emitted-code-note-p note)
880                    (incf total)
881                    (when (code-note-code-coverage note)
882                      (incf covered)))
883                  (loop for sub in (coverage-subnotes note)
884                        unless (entry-code-note-p sub) do (rec sub))))
885         (rec note))))
886    (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
887
888(defun count-covered-sexps (coverage)
889  ;; Count the number of source expressions that have been entered (regardless
890  ;; of whether or not they are completely covered).
891  (let ((entered 0) (covered 0) (total 0))
892    (map-coverage-entry-notes
893     coverage
894     (lambda (note)
895       (labels ((rec (note)
896                  (when (code-note-source-note note)
897                    #+debug (format t "~&~s" note)
898                    (incf total)
899                    (when (code-note-code-coverage note)
900                      (incf entered)
901                      (when (eq (code-note-code-coverage note) 'full)
902                        (incf covered))))
903                  (loop for sub in (coverage-subnotes note)
904                        unless (entry-code-note-p sub) do (rec sub))))
905         (rec note))))
906    (list total
907          entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
908          covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
909
910(defun count-unreached-branches (coverage)
911  ;; Count the number of maximal unentered forms
912  (let ((count 0))
913    (map-coverage-entry-notes
914     coverage
915     (lambda (note)
916       (labels ((rec (note parent)
917                  (case (code-note-code-coverage note)
918                    ((full) nil)
919                    ((nil) (when parent (incf count)))
920                    (t (loop for sub in (coverage-subnotes note)
921                             unless (entry-code-note-p sub) do (rec sub note))))))
922         (rec note nil))))
923    count))
924
925(defun write-coverage-styles (html-stream)
926  (format html-stream "<style type='text/css'>
927*.st~a { background-color: #ffaaaa }
928*.st~a { background-color: #aaffaa }
929*.st~a { background-color: #44dd44 }
930*.key { margin: 20px; width: 88ex }
931*.source { width: 120ex; background-color: #eeeeee; padding-left: 5px;
932             /* border-style: solid none none none; border-width: 1px;
933             border-color: #dddddd */
934             white-space: pre; }
935
936*.acode { border-left: 1px dashed #c0c0c0;
937         margin-top: 1ex;
938         margin-left: 6ex;
939         margin-bottom: 2ex;
940         white-space: pre;
941         display: none; }
942
943*.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
944
945*.toggle { font-size: small; }
946
947table.summary tr.head-row { background-color: #aaaaff }
948table.summary tr td.text-cell { text-align: left }
949table.summary tr td.main-head { text-align: center }
950table.summary tr td { text-align: right }
951table.summary tr.even { background-color: #eeeeff }
952table.summary tr.subheading { background-color: #aaaaff}
953table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
954
955</style>
956
957<script type='text/javascript'>
958function swap (id) {
959  var acode = document.getElementById('a' + id);
960  var prompt = document.getElementById('p' + id);
961  if (acode.style.display == 'block') {
962      acode.style.display = 'none';
963      prompt.innerHTML = 'Show expansion';
964  } else {
965    acode.style.display = 'block';
966    prompt.innerHTML = 'Hide expansion';
967  }
968}
969</script>
970"
971          $not-executed-style
972          $partially-covered-style
973          $totally-covered-style
974          ))
975
Note: See TracBrowser for help on using the repository browser.