cl-coverage-tools/cli-coverage.lisp at main · cl-sdk/cl-coverage-tools · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
(defpackage #:cl-coverage-reporter.cli
  (:use #:cl)
  (:export
   #:report))

(in-package :cl-coverage-reporter.cli)

(defparameter *filename-length* 40
  "Limit the length of the displayed file name.")

(defun system-files (system-designator)
  "Return a list of pathname objects for all files in SYSTEM-DESIGNATOR."
  (let* ((sys (asdf:find-system system-designator))
         (components (asdf:component-children sys)))
    (labels ((collect-files (component)
               (etypecase component
                 (asdf:cl-source-file
                  (list (asdf:component-pathname component)))
                 (asdf:module
                  (mapcan #'collect-files (asdf:component-children component)))
                 (asdf:system
                  (mapcan #'collect-files (asdf:component-children component))))))
      (mapcan #'collect-files components))))

(defun calculate (expressions)
  (let ((results (list :expression-hit 0
                       :expression-missed 0
                       :branch-hit 0
                       :branch-missed 0)))
    (loop for expression in expressions
          do (destructuring-bind (kind executed position length)
                 expression
               (declare (ignorable position length))
               (incf (getf results (if executed
                                       (if (eq :expression kind)
                                           :expression-hit
                                           :branch-hit)
                                       (if (eq :expression kind)
                                           :expression-missed
                                           :branch-missed)))))
          finally (return results))))

(defun report (systems)
  "Write a report to *standard-output* for the selected SYSTEMS.
 NOTE: For now, it only works for systems that contains a single package."
  (labels ((run (pkg files table)
             (loop for file in files
                   for filename = (namestring file)
                   collect (progn
                             (sb-cover::refresh-coverage-info filename)
                             (let* ((data (calculate
                                           (cl-coverage-tools:process-coverage-data
                                            pkg
                                            filename))))
                               (let ((name (if (>= (length filename) *filename-length*)
                                               (concatenate 'string
                                                            "..."
                                                           (subseq filename
                                                                   (- (length filename) *filename-length*)
                                                                   (length filename)))
                                               filename)))
                                 (ascii-table:add-row table (list name
                                                             (getf data :branch-hit)
                                                             (getf data :expression-hit)
                                                             (getf data :branch-missed)
                                                             (getf data :expression-missed)))))))))
    (let* ((table (ascii-table:make-table
                   '("File" "Branches" "Expressions" "Branches missed"  "Expressions missed")
                   :header "Coverage"))
           (results (loop for system-name in systems
                          collect (run (uiop:find-package* system-name)
                                       (system-files system-name)
                                       table))))
      (ascii-table:display table))))