source: branches/qres/ccl/library/cover.lisp @ 13685

Last change on this file since 13685 was 13685, checked in by gz, 10 years ago

Store checksum with code coverage info, signal error if try to color a different file than stored; Also while in there, add a restart to coverage coloring to let you skip a file if there are any errors.

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