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