scm/coverage.scm

   1 (define-module (scm coverage))
   2
   3 (use-modules (lily)
   4              (ice-9 rdelim)
   5              (ice-9 regex)
   6              (ice-9 format))
   7
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 (define-public (coverage:show-all filter?)
  11   (let*
  12       ((keys
  13         (filter filter?
  14                 (sort (map car (hash-table->alist coverage-table)) string<? ))))
  15
  16   (newline)
  17   (for-each
  18    (lambda (k)
  19
  20      (format #t "Coverage for file: ~a\n" k)
  21      (display-coverage
  22       k (hash-ref coverage-table k)
  23       (format #f "~a.cov" (basename k))))
  24    keys)))
  25
  26
  27 (define-public (coverage:enable)
  28   (trap-set! memoize-symbol-handler record-coverage)
  29   (trap-enable 'memoize-symbol)
  30   (trap-enable 'traps))
  31
  32
  33 (define-public (coverage:disable)
  34   (trap-set! memoize-symbol-handler #f)
  35   (trap-disable 'memoize-symbol))
  36
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38
  39 (define coverage-table (make-hash-table 57))
  40
  41 (define (read-lines port)
  42   (string-split (read-delimited "" port) #\newline))
  43
  44 (define (display-coverage file vec out-file)
  45   (let*
  46       ((lines (read-lines (open-file file "r")))
  47        (format-str "~8@a: ~5@a:~a\n")
  48        (out (if out-file (open-output-file out-file)
  49                 (current-output-port))))
  50
  51     (format out format-str "-" 0 (format #f "Source:~a" file))
  52     (do
  53         ((i 0 (1+ i))
  54          (l lines (cdr l)))
  55         ((or (null? l) ))
  56
  57       (format out format-str
  58                        (cond
  59                         ((and (< i (vector-length vec)) (vector-ref vec i)) "1")
  60                         ((and (string-contains file ".ly") (string-match "^[ \t]*%.*$" (car l)))
  61                          "-")
  62                         ((string-match  "^[ \t]*[()'`,]*$" (car l))
  63                          "-")
  64                         ((string-match  "^[ \t]*;.*$" (car l))
  65
  66                          "-")
  67                         (else "0"))
  68                        (1+ i)
  69                        (car l)))))
  70
  71 (define (record-coverage key cont exp env)
  72   (let*
  73       ((name (source-property exp 'filename))
  74        (line (source-property exp 'line))
  75        (vec (and name (hash-ref coverage-table name #f)))
  76        (veclen (and vec (vector-length vec)))
  77        (veccopy (lambda (src dst)
  78                   (vector-move-left! src 0 (vector-length src)
  79                                      dst 0)
  80                   dst)))
  81     (if (and line name)
  82         (begin
  83           (if (or (not vec) (>= line (vector-length vec)))
  84               (set! vec
  85                     (hash-set! coverage-table name
  86                                 (if vec
  87                                     (veccopy vec (make-vector (1+ line) #f))
  88                                     (make-vector (1+ line) #f)))))
  89
  90           (vector-set! vec line #t))
  91     )))
  92
  93
  94
  95
  96