scm/coverage.scm

   1 (define-module (scm coverage))
   2
   3 (use-modules (lily)
   4              (ice-9 rdelim)
   5              (ice-9 format))
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (define-public (coverage:show-all)
  10   (newline)
  11   (hash-fold
  12    (lambda (key val acc)
  13      (if (string-contains key "lilypond")
  14          (begin
  15            (format #t
  16                  "
  17 Coverage for file: ~a
  18 "
  19                  key)
  20          (display-coverage key val)))
  21      #t)
  22    #t
  23    coverage-table))
  24
  25 (define-public (coverage:enable)
  26   (trap-set! memoize-symbol-handler record-coverage)
  27   (trap-enable 'memoize-symbol)
  28   (trap-enable 'traps))
  29
  30 (define-public (coverage:disable)
  31   (trap-set! memoize-symbol-handler #f)
  32   (trap-disable 'memoize-symbol))
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35
  36 (define coverage-table (make-hash-table 57))
  37
  38 (define (read-lines port)
  39   (string-split (read-delimited "" port) #\newline))
  40
  41 (define (display-coverage file vec)
  42   (let*
  43       ((lines (read-lines (open-file file "r"))))
  44
  45     (do
  46         ((i 0 (1+ i))
  47          (l lines (cdr l)))
  48         ((or (null? l) (>= i (vector-length vec))))
  49
  50       (display (format #f "~8a: ~a\n"
  51                        (if (vector-ref vec i)
  52                            "#t"
  53                            "") (car l))))))
  54
  55 (define (record-coverage key cont exp env)
  56   (let*
  57       ((name (source-property exp 'filename))
  58        (line (source-property exp 'line))
  59        (vec (and name (hashv-ref coverage-table name #f)))
  60        (veclen (and vec (vector-length vec)))
  61        (veccopy (lambda (src dst)
  62                   (vector-move-left! src 0 (vector-length src)
  63                                      dst 0)
  64                   dst)))
  65     (if (and line name)
  66         (begin
  67           (if (or (not vec) (>= line (vector-length vec)))
  68               (set! vec
  69                     (hashv-set! coverage-table name
  70                                 (if vec
  71                                     (veccopy vec (make-vector (1+ line) #f))
  72                                     (make-vector (1+ line) #f)))))
  73
  74           (vector-set! vec line #t))
  75     )))
  76
  77
  78
  79
  80