| 1 | ;;; Code coverage reporting facility, based on the SBCL's |
|---|
| 2 | ;;; sb-cover written by Juho Snellman, and placed under public domain. |
|---|
| 3 | ;;; Port to ccl by gz@clozure.com |
|---|
| 4 | |
|---|
| 5 | (in-package :ccl) |
|---|
| 6 | |
|---|
| 7 | (export '(*compile-code-coverage* |
|---|
| 8 | report-coverage |
|---|
| 9 | reset-coverage |
|---|
| 10 | clear-coverage |
|---|
| 11 | save-coverage-in-file |
|---|
| 12 | restore-coverage-from-file)) |
|---|
| 13 | |
|---|
| 14 | (defconstant $not-executed-style 2) |
|---|
| 15 | (defconstant $totally-covered-style 5) |
|---|
| 16 | (defconstant $partially-covered-style 6) |
|---|
| 17 | |
|---|
| 18 | (defparameter *file-coverage* ()) |
|---|
| 19 | (defparameter *coverage-subnotes* (make-hash-table :test #'eq)) |
|---|
| 20 | (defparameter *emitted-code-notes* (make-hash-table :test #'eq)) |
|---|
| 21 | (defparameter *entry-code-notes* (make-hash-table :test #'eq)) |
|---|
| 22 | |
|---|
| 23 | |
|---|
| 24 | (defun file-coverage-file (entry) |
|---|
| 25 | (car entry)) |
|---|
| 26 | |
|---|
| 27 | (defun file-coverage-functions (entry) |
|---|
| 28 | (cadr entry)) |
|---|
| 29 | |
|---|
| 30 | (defun file-coverage-toplevel-functions (entry) |
|---|
| 31 | (cddr entry)) |
|---|
| 32 | |
|---|
| 33 | (defun coverage-subnotes (note) |
|---|
| 34 | (gethash note *coverage-subnotes*)) |
|---|
| 35 | |
|---|
| 36 | (defun emitted-code-note-p (note) |
|---|
| 37 | (gethash note *emitted-code-notes*)) |
|---|
| 38 | |
|---|
| 39 | (defun entry-code-note-p (note) |
|---|
| 40 | (gethash note *entry-code-notes*)) |
|---|
| 41 | |
|---|
| 42 | (defmacro lfunloop (for var in function &body loop-body) |
|---|
| 43 | (assert (and (memq for '(for as)) (eq in 'in))) |
|---|
| 44 | (let ((fn (gensym)) |
|---|
| 45 | (lfv (gensym)) |
|---|
| 46 | (i (gensym))) |
|---|
| 47 | `(loop with ,fn = ,function |
|---|
| 48 | with ,lfv = (function-to-function-vector ,fn) |
|---|
| 49 | for ,i from #+ppc-target 0 #+x86-target (%function-code-words fn) below (uvsize ,lfv) |
|---|
| 50 | as ,var = (uvref ,lfv ,i) |
|---|
| 51 | ,@loop-body))) |
|---|
| 52 | |
|---|
| 53 | |
|---|
| 54 | (defun map-function-coverage (lfun fn &optional refs) |
|---|
| 55 | (let ((refs (cons lfun refs))) |
|---|
| 56 | (lfunloop for imm in lfun |
|---|
| 57 | when (code-note-p imm) |
|---|
| 58 | do (funcall fn imm) |
|---|
| 59 | when (and (functionp imm) |
|---|
| 60 | (not (memq imm refs))) |
|---|
| 61 | do (map-function-coverage imm fn refs)))) |
|---|
| 62 | |
|---|
| 63 | (defun get-function-coverage (fn refs) |
|---|
| 64 | (let ((entry (function-entry-code-note fn)) |
|---|
| 65 | (refs (cons fn refs))) |
|---|
| 66 | (declare (dynamic-extent refs)) |
|---|
| 67 | (when entry |
|---|
| 68 | ;; This can occur legitimately when the same source is used multiple times, |
|---|
| 69 | ;; as when 'body' contains local fn defs in something like: |
|---|
| 70 | ;; (defmacro define-twice (defn) (defun fn-1 ,@defn) (defun fn-2 ,@defn)) |
|---|
| 71 | #+never-mind |
|---|
| 72 | (when (and (gethash entry *entry-code-notes*) |
|---|
| 73 | (neq fn (gethash entry *entry-code-notes*))) |
|---|
| 74 | (cerror "ignore" "Note ~s is entry note for both ~s and ~s" |
|---|
| 75 | entry fn (gethash entry *entry-code-notes*))) |
|---|
| 76 | (setf (gethash entry *entry-code-notes*) fn)) |
|---|
| 77 | (nconc |
|---|
| 78 | (and entry (list fn)) |
|---|
| 79 | (lfunloop for imm in fn |
|---|
| 80 | when (code-note-p imm) |
|---|
| 81 | do (let ((parent (code-note-parent-note imm))) |
|---|
| 82 | (setf (gethash imm *emitted-code-notes*) t) |
|---|
| 83 | (when parent |
|---|
| 84 | (if (consp parent) |
|---|
| 85 | (loop for p in parent |
|---|
| 86 | do (pushnew imm (gethash p *coverage-subnotes*))) |
|---|
| 87 | (pushnew imm (gethash parent *coverage-subnotes*))))) |
|---|
| 88 | when (and (functionp imm) |
|---|
| 89 | (not (memq imm refs))) |
|---|
| 90 | nconc (get-function-coverage imm refs))))) |
|---|
| 91 | |
|---|
| 92 | |
|---|
| 93 | (defun get-coverage () |
|---|
| 94 | (setq *file-coverage* nil) |
|---|
| 95 | (clrhash *coverage-subnotes*) |
|---|
| 96 | (clrhash *emitted-code-notes*) |
|---|
| 97 | (clrhash *entry-code-notes*) |
|---|
| 98 | (loop for data in *code-covered-functions* |
|---|
| 99 | when (consp data) |
|---|
| 100 | do (destructuring-bind (file . toplevel-functions) data |
|---|
| 101 | (push (list* file |
|---|
| 102 | ;; Duplicates are possible if you have multiple instances of |
|---|
| 103 | ;; (load-time-value (foo)) where (foo) returns an lfun. |
|---|
| 104 | ;; CL-PPCRE does that. |
|---|
| 105 | (delete-duplicates |
|---|
| 106 | (loop for fn across toplevel-functions |
|---|
| 107 | nconc (get-function-coverage fn nil))) |
|---|
| 108 | toplevel-functions) |
|---|
| 109 | *file-coverage*)))) |
|---|
| 110 | |
|---|
| 111 | (defun show-notes (note) |
|---|
| 112 | (when (functionp note) |
|---|
| 113 | (setq note (function-entry-code-note note))) |
|---|
| 114 | (labels ((show (note indent label) |
|---|
| 115 | (dotimes (i indent) (write-char #\space)) |
|---|
| 116 | (format t "~a ~a" label note) |
|---|
| 117 | (unless (emitted-code-note-p note) |
|---|
| 118 | (format t " [Not Emitted]")) |
|---|
| 119 | (when (entry-code-note-p note) |
|---|
| 120 | (format t " (Entry to ~s)" (entry-code-note-p note))) |
|---|
| 121 | (format t "~%") |
|---|
| 122 | (when (code-note-p note) |
|---|
| 123 | (loop with subindent = (+ indent 3) |
|---|
| 124 | for sub in (coverage-subnotes note) as i upfrom 1 |
|---|
| 125 | do (show sub subindent (format nil "~a~d." label i)))))) |
|---|
| 126 | (show note 0 ""))) |
|---|
| 127 | |
|---|
| 128 | (defun covered-functions-for-file (path) |
|---|
| 129 | (let* ((true-path (probe-file path)) |
|---|
| 130 | (data (find-if #'(lambda (data) |
|---|
| 131 | (or (equalp (car data) path) |
|---|
| 132 | (and true-path (equalp (probe-file (car data)) true-path)))) |
|---|
| 133 | *code-covered-functions*))) |
|---|
| 134 | (cdr data))) |
|---|
| 135 | |
|---|
| 136 | (defun clear-coverage () |
|---|
| 137 | "Clear all files from the coverage database. The files will be re-entered |
|---|
| 138 | into the database when the FASL files (produced by compiling with |
|---|
| 139 | CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the |
|---|
| 140 | image." |
|---|
| 141 | (setq *code-covered-functions* nil)) |
|---|
| 142 | |
|---|
| 143 | (defun reset-coverage () |
|---|
| 144 | "Reset all coverage data back to the `Not executed` state." |
|---|
| 145 | (flet ((reset (note) (setf (code-note-code-coverage note) nil))) |
|---|
| 146 | (loop for data in *code-covered-functions* |
|---|
| 147 | do (typecase data |
|---|
| 148 | (cons ;; (source-file . functions) |
|---|
| 149 | (loop for fn across (cdr data) |
|---|
| 150 | do (map-function-coverage fn #'reset))) |
|---|
| 151 | (function (map-function-coverage data #'reset)))))) |
|---|
| 152 | |
|---|
| 153 | (defun save-function-coverage (fn &optional (refs ())) |
|---|
| 154 | (push fn refs) |
|---|
| 155 | (cons (let ((name (function-name fn))) |
|---|
| 156 | (and (symbolp name) |
|---|
| 157 | (symbol-package name) |
|---|
| 158 | name)) |
|---|
| 159 | (lfunloop for imm in fn |
|---|
| 160 | when (code-note-p imm) |
|---|
| 161 | collect (code-note-code-coverage imm) |
|---|
| 162 | when (and (functionp imm) (not (memq imm refs))) |
|---|
| 163 | collect (save-function-coverage imm refs)))) |
|---|
| 164 | |
|---|
| 165 | |
|---|
| 166 | |
|---|
| 167 | (defun save-coverage () |
|---|
| 168 | "Returns an opaque representation of the current code coverage state. |
|---|
| 169 | The only operation that may be done on the state is passing it to |
|---|
| 170 | RESTORE-COVERAGE. The representation is guaranteed to be readably printable. |
|---|
| 171 | A representation that has been printed and read back will work identically |
|---|
| 172 | in RESTORE-COVERAGE." |
|---|
| 173 | (loop for data in *code-covered-functions* |
|---|
| 174 | when (consp data) |
|---|
| 175 | collect (cons (car data) |
|---|
| 176 | (map 'vector #'save-function-coverage (cdr data))))) |
|---|
| 177 | |
|---|
| 178 | (defun restore-coverage (coverage-state) |
|---|
| 179 | "Restore the code coverage data back to an earlier state produced by |
|---|
| 180 | SAVE-COVERAGE." |
|---|
| 181 | (loop for (saved-file . saved-fns) in coverage-state |
|---|
| 182 | as fns = (covered-functions-for-file saved-file) |
|---|
| 183 | do (flet ((mismatched (why &rest args) |
|---|
| 184 | (error "Mismatched coverage data for ~s, ~?" saved-file why args))) |
|---|
| 185 | (cond ((null fns) |
|---|
| 186 | (warn "Couldn't restore saved coverage for ~s, no matching file present" |
|---|
| 187 | saved-file)) |
|---|
| 188 | ((not (eql (length fns) (length saved-fns))) |
|---|
| 189 | (mismatched "was ~s functions, now ~s" (length saved-fns) (length fns))) |
|---|
| 190 | (t |
|---|
| 191 | (loop for fn across fns |
|---|
| 192 | for saved-data across saved-fns |
|---|
| 193 | do (labels |
|---|
| 194 | ((rec (fn saved-data refs) |
|---|
| 195 | (push fn refs) |
|---|
| 196 | (let* ((name (car saved-data)) |
|---|
| 197 | (saved-imms (cdr saved-data))) |
|---|
| 198 | (unless (equalp name |
|---|
| 199 | (let ((name (function-name fn))) |
|---|
| 200 | (and (symbolp name) name))) |
|---|
| 201 | (mismatched "had ~s now have ~s" name (function-name fn))) |
|---|
| 202 | (lfunloop for imm in fn |
|---|
| 203 | when (code-note-p imm) |
|---|
| 204 | do (if (or (null saved-imms) (consp (car saved-imms))) |
|---|
| 205 | (mismatched "in ~s" name) |
|---|
| 206 | (setf (code-note-code-coverage imm) (pop saved-imms))) |
|---|
| 207 | when (and (functionp imm) |
|---|
| 208 | (not (memq imm refs))) |
|---|
| 209 | do (if (or (null saved-imms) (atom (car saved-imms))) |
|---|
| 210 | (mismatched "in ~s" name) |
|---|
| 211 | (rec imm (pop saved-imms) refs)))))) |
|---|
| 212 | (rec fn saved-data nil)))))))) |
|---|
| 213 | |
|---|
| 214 | (defun save-coverage-in-file (pathname) |
|---|
| 215 | "Call SAVE-COVERAGE and write the results of that operation into the |
|---|
| 216 | file designated by PATHNAME." |
|---|
| 217 | (with-open-file (stream pathname |
|---|
| 218 | :direction :output |
|---|
| 219 | :if-exists :supersede |
|---|
| 220 | :if-does-not-exist :create) |
|---|
| 221 | (with-standard-io-syntax |
|---|
| 222 | (let ((*package* *ccl-package*)) |
|---|
| 223 | (write (save-coverage) :stream stream))) |
|---|
| 224 | (values))) |
|---|
| 225 | |
|---|
| 226 | (defun restore-coverage-from-file (pathname) |
|---|
| 227 | "READ the contents of the file designated by PATHNAME and pass the |
|---|
| 228 | result to RESTORE-COVERAGE." |
|---|
| 229 | (with-open-file (stream pathname :direction :input) |
|---|
| 230 | (with-standard-io-syntax |
|---|
| 231 | (let ((*package* *ccl-package*)) |
|---|
| 232 | (restore-coverage (read stream)))) |
|---|
| 233 | (values))) |
|---|
| 234 | |
|---|
| 235 | (defun common-coverage-directory () |
|---|
| 236 | (let* ((host :unknown) |
|---|
| 237 | (rev-dir ())) |
|---|
| 238 | (loop for data in *code-covered-functions* |
|---|
| 239 | when (consp data) |
|---|
| 240 | do (let ((file (probe-file (car data)))) |
|---|
| 241 | (when file |
|---|
| 242 | (cond ((eq host :unknown) |
|---|
| 243 | (setq host (pathname-host file) |
|---|
| 244 | rev-dir (reverse (pathname-directory file)))) |
|---|
| 245 | ((not (equalp host (pathname-host file))) |
|---|
| 246 | (return-from common-coverage-directory nil)) |
|---|
| 247 | (t |
|---|
| 248 | (let* ((path (pathname-directory file)) |
|---|
| 249 | (dir-len (length rev-dir)) |
|---|
| 250 | (len (length path))) |
|---|
| 251 | (if (< len dir-len) |
|---|
| 252 | (setq rev-dir (nthcdr (- dir-len len) rev-dir)) |
|---|
| 253 | (setq path (subseq path 0 dir-len))) |
|---|
| 254 | (loop for pp on (reverse path) until (equalp pp rev-dir) |
|---|
| 255 | do (pop rev-dir)))))))) |
|---|
| 256 | (unless (eq host :unknown) |
|---|
| 257 | (make-pathname :host host :directory (reverse rev-dir))))) |
|---|
| 258 | |
|---|
| 259 | |
|---|
| 260 | (defun report-coverage (output-file &key (external-format :default) (statistics t)) |
|---|
| 261 | "Print a code coverage report of all instrumented files into DIRECTORY. |
|---|
| 262 | If DIRECTORY does not exist, it will be created. The main report will be |
|---|
| 263 | printed to the file cover-index.html. The external format of the source |
|---|
| 264 | files can be specified with the EXTERNAL-FORMAT parameter. |
|---|
| 265 | If :STATISTICS is non-nil, a CSV file is generated with a table. If |
|---|
| 266 | :STATISTICS is a filename, that file is used, else 'statistics.csv' is |
|---|
| 267 | written to the output directory. |
|---|
| 268 | " |
|---|
| 269 | (let* ((paths) |
|---|
| 270 | (directory (make-pathname :name nil :type nil :defaults output-file)) |
|---|
| 271 | (coverage-dir (common-coverage-directory)) |
|---|
| 272 | (*file-coverage* nil) |
|---|
| 273 | (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) |
|---|
| 274 | (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) |
|---|
| 275 | (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) |
|---|
| 276 | (get-coverage) |
|---|
| 277 | (ensure-directories-exist directory) |
|---|
| 278 | (loop for coverage in *file-coverage* |
|---|
| 279 | as file = (or (probe-file (file-coverage-file coverage)) |
|---|
| 280 | (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage)) |
|---|
| 281 | nil)) |
|---|
| 282 | do (when file |
|---|
| 283 | (let* ((src-name (enough-namestring file coverage-dir)) |
|---|
| 284 | (html-name (substitute #\_ #\: (substitute #\_ #\. (substitute #\_ #\/ src-name))))) |
|---|
| 285 | (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory) |
|---|
| 286 | :direction :output |
|---|
| 287 | :if-exists :supersede |
|---|
| 288 | :if-does-not-exist :create) |
|---|
| 289 | (report-file-coverage coverage stream external-format)) |
|---|
| 290 | (push (list* src-name html-name coverage) paths)))) |
|---|
| 291 | (setq paths (sort paths #'string< :key #'car)) |
|---|
| 292 | (when (null paths) |
|---|
| 293 | (error "No code coverage data available")) |
|---|
| 294 | (let* ((index-file (merge-pathnames output-file "index.html")) |
|---|
| 295 | (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) |
|---|
| 296 | (pathnamep statistics)) |
|---|
| 297 | (merge-pathnames statistics "statistics.csv") |
|---|
| 298 | "statistics.csv") |
|---|
| 299 | output-file)))) |
|---|
| 300 | (with-open-file (html-stream index-file |
|---|
| 301 | :direction :output |
|---|
| 302 | :if-exists :supersede |
|---|
| 303 | :if-does-not-exist :create) |
|---|
| 304 | (if stats-file |
|---|
| 305 | (with-open-file (stats-stream stats-file |
|---|
| 306 | :direction :output |
|---|
| 307 | :if-exists :supersede |
|---|
| 308 | :if-does-not-exist :create) |
|---|
| 309 | (report-coverage-to-streams paths html-stream stats-stream)) |
|---|
| 310 | (report-coverage-to-streams paths html-stream nil))) |
|---|
| 311 | (values index-file stats-file)))) |
|---|
| 312 | |
|---|
| 313 | (defun report-coverage-to-streams (paths html-stream stats-stream) |
|---|
| 314 | (write-coverage-styles html-stream) |
|---|
| 315 | (unless paths |
|---|
| 316 | (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?") |
|---|
| 317 | (format html-stream "<h3>No code coverage data found.</h3>~%") |
|---|
| 318 | (when stats-stream (format stats-stream "No code coverage data found.~%")) |
|---|
| 319 | (return-from report-coverage-to-streams)) |
|---|
| 320 | (format html-stream "<table class='summary'>") |
|---|
| 321 | (coverage-stats-head html-stream stats-stream) |
|---|
| 322 | (loop for prev = nil then src-name |
|---|
| 323 | for (src-name report-name . coverage) in paths |
|---|
| 324 | for even = nil then (not even) |
|---|
| 325 | do (when (or (null prev) |
|---|
| 326 | (not (equal (pathname-directory (pathname src-name)) |
|---|
| 327 | (pathname-directory (pathname prev))))) |
|---|
| 328 | (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name)))) |
|---|
| 329 | (format html-stream "<tr class='subheading'><td colspan='11'>~A</td></tr>~%" dir) |
|---|
| 330 | (when stats-stream (format stats-stream "~a~%" dir)))) |
|---|
| 331 | do (coverage-stats-data html-stream stats-stream coverage even report-name src-name)) |
|---|
| 332 | (format html-stream "</table>")) |
|---|
| 333 | |
|---|
| 334 | (defun precompute-note-coverage (note &optional refs) |
|---|
| 335 | (when note |
|---|
| 336 | (let ((subnotes (coverage-subnotes note)) |
|---|
| 337 | (refs (cons note refs))) |
|---|
| 338 | (declare (dynamic-extent refs)) |
|---|
| 339 | (loop for sub in subnotes |
|---|
| 340 | when (member sub refs) |
|---|
| 341 | do (break "Circularity!!") |
|---|
| 342 | unless (member sub refs) |
|---|
| 343 | do (precompute-note-coverage sub refs)) |
|---|
| 344 | (when (and (or (not (emitted-code-note-p note)) |
|---|
| 345 | (code-note-code-coverage note)) |
|---|
| 346 | (loop for sub in subnotes |
|---|
| 347 | always (or (eq 'full (code-note-code-coverage sub)) |
|---|
| 348 | (entry-code-note-p sub)))) |
|---|
| 349 | (setf (code-note-code-coverage note) 'full))))) |
|---|
| 350 | |
|---|
| 351 | |
|---|
| 352 | (defun fill-with-text-style (coverage location-note styles) |
|---|
| 353 | (let ((style (case coverage |
|---|
| 354 | ((full) $totally-covered-style) |
|---|
| 355 | ((nil) $not-executed-style) |
|---|
| 356 | (t $partially-covered-style)))) |
|---|
| 357 | (fill styles style |
|---|
| 358 | :start (source-note-start-pos location-note) |
|---|
| 359 | :end (source-note-end-pos location-note)))) |
|---|
| 360 | |
|---|
| 361 | (defun update-text-styles (note styles) |
|---|
| 362 | (when (source-note-p note) |
|---|
| 363 | (fill-with-text-style (code-note-code-coverage note) note styles)) |
|---|
| 364 | (unless (and (emitted-code-note-p note) |
|---|
| 365 | (memq (code-note-code-coverage note) '(nil full)) |
|---|
| 366 | ;; If not a source note, descend in case have some subnotes |
|---|
| 367 | ;; that can be shown |
|---|
| 368 | (source-note-p note)) |
|---|
| 369 | (loop for sub in (coverage-subnotes note) |
|---|
| 370 | unless (entry-code-note-p sub) |
|---|
| 371 | do (update-text-styles sub styles)))) |
|---|
| 372 | |
|---|
| 373 | (defun colorize-source-note (note styles) |
|---|
| 374 | ;; Change coverage flag to 'full if all subforms are covered. |
|---|
| 375 | (precompute-note-coverage note) |
|---|
| 376 | ;; Now actually change text styles, from outside in. |
|---|
| 377 | ;; But first, a special kludge: |
|---|
| 378 | ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function " |
|---|
| 379 | ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner |
|---|
| 380 | ;; function got executed. However, suppose have a macro "(setq-fun foo (x) x)" that |
|---|
| 381 | ;; expanded into the above, there isn't a clear way to show the distinction between |
|---|
| 382 | ;; just referencing the inner fn and executing it. In practice, the colorization |
|---|
| 383 | ;; based on the inner function is more interesting -- consider for example DEFUN, |
|---|
| 384 | ;; nobody cares if the defun form itself got executed. |
|---|
| 385 | ;; So when showing the colorization of an inner function, we usurp the whole nearest source |
|---|
| 386 | ;; form, provided it can be done unambiguously. |
|---|
| 387 | (loop for n = note then parent until (source-note-p n) |
|---|
| 388 | as parent = (code-note-parent-note n) |
|---|
| 389 | do (unless (and parent |
|---|
| 390 | (labels ((no-other-entry-subnotes (n refs) |
|---|
| 391 | (let ((subs (coverage-subnotes n)) |
|---|
| 392 | (refs (cons n refs))) |
|---|
| 393 | (declare (dynamic-extent refs)) |
|---|
| 394 | (loop for sub in subs |
|---|
| 395 | always (or (memq sub refs) |
|---|
| 396 | (eq sub note) |
|---|
| 397 | (and (not (entry-code-note-p sub)) |
|---|
| 398 | (no-other-entry-subnotes sub refs))))))) |
|---|
| 399 | (no-other-entry-subnotes parent ()))) |
|---|
| 400 | (return nil)) |
|---|
| 401 | finally (fill-with-text-style (code-note-code-coverage note) n styles)) |
|---|
| 402 | (update-text-styles note styles)) |
|---|
| 403 | |
|---|
| 404 | (defun function-source-form-note (fn) |
|---|
| 405 | (loop for n = (function-entry-code-note fn) then (code-note-parent-note n) |
|---|
| 406 | do (when (null n) (return nil)) |
|---|
| 407 | do (when (source-note-p n) |
|---|
| 408 | (loop for s = (code-note-source n) while (source-note-p s) |
|---|
| 409 | do (setq n s)) |
|---|
| 410 | (return n)))) |
|---|
| 411 | |
|---|
| 412 | |
|---|
| 413 | (defun colorize-function (fn styles &optional refs) |
|---|
| 414 | (let* ((note (function-entry-code-note fn)) |
|---|
| 415 | (source (function-source-form-note fn)) |
|---|
| 416 | (refs (cons fn refs))) |
|---|
| 417 | (declare (dynamic-extent refs)) |
|---|
| 418 | ;; Colorize the body of the function |
|---|
| 419 | (when note |
|---|
| 420 | (colorize-source-note note styles)) |
|---|
| 421 | ;; And now any subfunction references |
|---|
| 422 | (lfunloop for imm in fn |
|---|
| 423 | when (and (functionp imm) |
|---|
| 424 | (not (memq imm refs)) |
|---|
| 425 | ;; Make sure this fn is in the source we're currently looking at. |
|---|
| 426 | ;; It might not be, if it is referenced via (load-time-value (foo)) |
|---|
| 427 | ;; where (foo) returns an lfun from some different source entirely. |
|---|
| 428 | ;; CL-PPCRE does that. |
|---|
| 429 | (or (null source) |
|---|
| 430 | (eq source (function-source-form-note imm)) |
|---|
| 431 | #+debug (progn |
|---|
| 432 | (warn "Ignoring ref to ~s from ~s" imm fn) |
|---|
| 433 | nil))) |
|---|
| 434 | do (colorize-function imm styles refs)))) |
|---|
| 435 | |
|---|
| 436 | (defun report-file-coverage (coverage html-stream external-format) |
|---|
| 437 | "Print a code coverage report of FILE into the stream HTML-STREAM." |
|---|
| 438 | (format html-stream "<html><head>") |
|---|
| 439 | (write-coverage-styles html-stream) |
|---|
| 440 | (format html-stream "</head><body>") |
|---|
| 441 | (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format) |
|---|
| 442 | (let ((string (make-string (file-length s)))) |
|---|
| 443 | (read-sequence string s) |
|---|
| 444 | string))) |
|---|
| 445 | (styles (make-array (length source) |
|---|
| 446 | :initial-element 0 |
|---|
| 447 | :element-type '(unsigned-byte 2)))) |
|---|
| 448 | (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) |
|---|
| 449 | (print-coverage-report html-stream coverage styles source) |
|---|
| 450 | (format html-stream "</body></html>"))) |
|---|
| 451 | |
|---|
| 452 | (defun print-coverage-report (html-stream coverage styles source) |
|---|
| 453 | (let ((*print-case* :downcase)) |
|---|
| 454 | (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" (file-coverage-file coverage)) |
|---|
| 455 | |
|---|
| 456 | (format html-stream "<table class='summary'>") |
|---|
| 457 | (coverage-stats-head html-stream nil) |
|---|
| 458 | (coverage-stats-data html-stream nil coverage) |
|---|
| 459 | (format html-stream "</table>") |
|---|
| 460 | |
|---|
| 461 | (format html-stream "<div class='key'><b>Key</b><br />~%") |
|---|
| 462 | (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style) |
|---|
| 463 | (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style) |
|---|
| 464 | (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style) |
|---|
| 465 | (format html-stream "<p></p><div><code>~%") |
|---|
| 466 | |
|---|
| 467 | (flet ((line (line) |
|---|
| 468 | (unless (eql line 0) |
|---|
| 469 | (format html-stream "</span>")) |
|---|
| 470 | (incf line) |
|---|
| 471 | (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code> " line) |
|---|
| 472 | line)) |
|---|
| 473 | (loop with line = (line 0) with col = 0 |
|---|
| 474 | for last-style = nil then style |
|---|
| 475 | for char across source |
|---|
| 476 | for style across styles |
|---|
| 477 | do (unless (eq style last-style) |
|---|
| 478 | (when last-style |
|---|
| 479 | (format html-stream "</span>")) |
|---|
| 480 | (format html-stream "<span class='state-~a'>" style)) |
|---|
| 481 | do (case char |
|---|
| 482 | ((#\Newline) |
|---|
| 483 | (setq style nil) |
|---|
| 484 | (setq col 0) |
|---|
| 485 | (setq line (line line))) |
|---|
| 486 | ((#\Space) |
|---|
| 487 | (incf col) |
|---|
| 488 | (write-string " " html-stream)) |
|---|
| 489 | ((#\Tab) |
|---|
| 490 | (dotimes (i (- 8 (mod col 8))) |
|---|
| 491 | (incf col) |
|---|
| 492 | (write-string " " html-stream))) |
|---|
| 493 | (t |
|---|
| 494 | (incf col) |
|---|
| 495 | (if (alphanumericp char) |
|---|
| 496 | (write-char char html-stream) |
|---|
| 497 | (format html-stream "&#~D;" (char-code char)))))) |
|---|
| 498 | (format html-stream "</code></div>")))) |
|---|
| 499 | |
|---|
| 500 | |
|---|
| 501 | (defun coverage-stats-head (html-stream stats-stream) |
|---|
| 502 | (format html-stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expressions</td><td class='main-head' colspan='7'>Functions</td></tr>") |
|---|
| 503 | (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>" |
|---|
| 504 | '("Source file" |
|---|
| 505 | "Total" "Covered" "% covered" |
|---|
| 506 | "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")) |
|---|
| 507 | (when stats-stream |
|---|
| 508 | (format stats-stream "~{~a~^,~}" |
|---|
| 509 | '("Source file" "Expressions Total" "Expressions Covered" "% Expressions Covered" |
|---|
| 510 | "Functions Total" "Functions Fully Covered" "% Functions Fully Covered" |
|---|
| 511 | "Functions Partly Covered" "% Functions Partly Covered" |
|---|
| 512 | "Functions Not Entered" "% Functions Not Entered")))) |
|---|
| 513 | |
|---|
| 514 | (defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name) |
|---|
| 515 | (format html-stream "<tr class='~:[odd~;even~]'>" evenp) |
|---|
| 516 | (if report-name |
|---|
| 517 | (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name src-name) |
|---|
| 518 | (format html-stream "<td class='text-cell'>~a</td>" (file-coverage-file coverage))) |
|---|
| 519 | (when stats-stream |
|---|
| 520 | (format stats-stream "~a," (file-coverage-file coverage))) |
|---|
| 521 | (let ((exp-counts (count-covered-expressions coverage))) |
|---|
| 522 | (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts) |
|---|
| 523 | (when stats-stream |
|---|
| 524 | (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) |
|---|
| 525 | (destructuring-bind (total . counts) (count-covered-functions coverage) |
|---|
| 526 | (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts) |
|---|
| 527 | (when stats-stream |
|---|
| 528 | (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts)))) |
|---|
| 529 | |
|---|
| 530 | (defun count-covered-functions (coverage) |
|---|
| 531 | (let ((fully 0) (partly 0) (never 0) (total 0)) |
|---|
| 532 | (map nil #'(lambda (function) |
|---|
| 533 | (let ((note (function-entry-code-note function))) |
|---|
| 534 | (when (and note |
|---|
| 535 | ;; Ignore toplevel functions created by the compiler. |
|---|
| 536 | (or (source-note-p note) |
|---|
| 537 | (code-note-parent-note note) |
|---|
| 538 | (code-note-source note))) |
|---|
| 539 | (incf total) |
|---|
| 540 | (case (code-note-code-coverage note) |
|---|
| 541 | ((full) (incf fully)) |
|---|
| 542 | ((nil) (incf never)) |
|---|
| 543 | (t (incf partly)))))) |
|---|
| 544 | (file-coverage-functions coverage)) |
|---|
| 545 | (if (> total 0) |
|---|
| 546 | (list total |
|---|
| 547 | fully (* 100.0 (/ fully total)) |
|---|
| 548 | partly (* 100.0 (/ partly total)) |
|---|
| 549 | never (* 100.0 (/ never total))) |
|---|
| 550 | '(0 0 -- 0 -- 0 --)))) |
|---|
| 551 | |
|---|
| 552 | (defun count-covered-expressions (coverage) |
|---|
| 553 | (let ((covered 0) (total 0)) |
|---|
| 554 | (map nil #'(lambda (function) |
|---|
| 555 | (let ((note (function-entry-code-note function))) |
|---|
| 556 | (when (and note |
|---|
| 557 | ;; Ignore toplevel functions created by the compiler. |
|---|
| 558 | (or (source-note-p note) |
|---|
| 559 | (code-note-parent-note note) |
|---|
| 560 | (code-note-source note))) |
|---|
| 561 | (labels ((rec (note) |
|---|
| 562 | (incf total) |
|---|
| 563 | (when (code-note-code-coverage note) |
|---|
| 564 | (incf covered)) |
|---|
| 565 | (loop for sub in (coverage-subnotes note) |
|---|
| 566 | unless (entry-code-note-p sub) do (rec sub)))) |
|---|
| 567 | (rec note))))) |
|---|
| 568 | (file-coverage-functions coverage)) |
|---|
| 569 | (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) |
|---|
| 570 | |
|---|
| 571 | |
|---|
| 572 | (defun write-coverage-styles (html-stream) |
|---|
| 573 | (format html-stream "<style type='text/css'> |
|---|
| 574 | *.state-~a { background-color: #ffaaaa } |
|---|
| 575 | *.state-~a { background-color: #aaffaa } |
|---|
| 576 | *.state-~a { background-color: #44dd44 } |
|---|
| 577 | div.key { margin: 20px; width: 88ex } |
|---|
| 578 | div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px; |
|---|
| 579 | /* border-style: solid none none none; border-width: 1px; |
|---|
| 580 | border-color: #dddddd */ } |
|---|
| 581 | |
|---|
| 582 | *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; } |
|---|
| 583 | |
|---|
| 584 | table.summary tr.head-row { background-color: #aaaaff } |
|---|
| 585 | table.summary tr td.text-cell { text-align: left } |
|---|
| 586 | table.summary tr td.main-head { text-align: center } |
|---|
| 587 | table.summary tr td { text-align: right } |
|---|
| 588 | table.summary tr.even { background-color: #eeeeff } |
|---|
| 589 | table.summary tr.subheading { background-color: #aaaaff} |
|---|
| 590 | table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; } |
|---|
| 591 | </style>" |
|---|
| 592 | $not-executed-style |
|---|
| 593 | $partially-covered-style |
|---|
| 594 | $totally-covered-style |
|---|
| 595 | )) |
|---|
