scm/coverage.scm

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