141 lines
5.5 KiB
Scheme
141 lines
5.5 KiB
Scheme
#lang mzscheme
|
|
|
|
(require mzlib/class
|
|
mred
|
|
framework
|
|
(prefix list: mzlib/list)
|
|
mzlib/integer-set)
|
|
|
|
(provide (all-defined))
|
|
|
|
(define coverage-track%
|
|
(class* object% ()
|
|
|
|
(super-instantiate ())
|
|
|
|
;; interger-set
|
|
(define covered (make-range))
|
|
;; [hashtable-of scheme-val -> integer-set]
|
|
(define covered-from-src (make-hash-table 'weak))
|
|
;; (listof covered-from-src keys)
|
|
(define current-coverage-srcs null)
|
|
|
|
(define/public (covered-position start span)
|
|
(let ([new-range (make-range start (+ start span))])
|
|
(set! covered (union covered new-range))
|
|
(for-each (lambda (key covered-set)
|
|
(hash-table-put! covered-from-src key
|
|
(union covered-set new-range)))
|
|
current-coverage-srcs
|
|
(map (lambda (key)
|
|
(hash-table-get covered-from-src key (make-range)))
|
|
current-coverage-srcs))))
|
|
|
|
(define/public (register-coverage-point src)
|
|
(set! current-coverage-srcs (cons src current-coverage-srcs)))
|
|
|
|
(define/public (unregister-coverage-point src)
|
|
(set! current-coverage-srcs (list:remq src current-coverage-srcs)))
|
|
|
|
(define/public (covers-span? start span)
|
|
(zero? (card (difference (make-range start (+ start span)) covered))))
|
|
|
|
(define/public (covers-spans? srcs)
|
|
(andmap (lambda (s) (covers-span? (car s) (cdr s))) srcs))
|
|
|
|
(define/public (display-coverage editor)
|
|
(highlight-covered editor covered))
|
|
|
|
(define/public (display-covered-portion editor coverage-point)
|
|
(highlight-covered editor (hash-table-get covered-from-src coverage-point
|
|
(make-range))))
|
|
|
|
|
|
(define/private (highlight-covered editor int-set)
|
|
(let* ([style-list (editor:get-standard-style-list)]
|
|
[uncovered-highlight (send style-list find-named-style
|
|
"profj:syntax-colors:scheme:uncovered")]
|
|
[covered-highlight (send style-list find-named-style
|
|
"profj:syntax-colors:scheme:covered")])
|
|
(letrec ([color-buff
|
|
(lambda ()
|
|
(cond
|
|
[(or (send editor is-locked?)
|
|
(send editor in-edit-sequence?))
|
|
(queue-callback color-buff)]
|
|
[else
|
|
(unless (send editor test-froze-colorer?)
|
|
(send editor freeze-colorer)
|
|
(send editor toggle-test-status))
|
|
(send editor begin-test-color)
|
|
(send editor change-style
|
|
uncovered-highlight 0
|
|
(send editor last-position) #f)
|
|
(let loop ([positions (integer-set-contents int-set)])
|
|
(unless (null? positions)
|
|
(send editor change-style covered-highlight
|
|
(sub1 (caar positions))
|
|
(sub1 (cdar positions))
|
|
#f)
|
|
(loop (cdr positions))))
|
|
(send editor end-test-color)]))])
|
|
(queue-callback color-buff))))))
|
|
|
|
(define (test-coverage-button-mixin parent)
|
|
(class* parent ()
|
|
(super-instantiate ())
|
|
|
|
(define/public (insert-covered-button dest coverage src src-editor partial?)
|
|
(let* ([button-editor (new (editor:standard-style-list-mixin text%)
|
|
[auto-wrap #t])]
|
|
[snip (new editor-snip% (editor button-editor) (with-border? #t))]
|
|
[start (send dest get-end-position)])
|
|
(send snip set-style
|
|
(send (send dest get-style-list) find-named-style "Standard"))
|
|
(send button-editor insert
|
|
(if partial?
|
|
"Highlight covered expressions"
|
|
"Highlight all covered expressions"))
|
|
(send dest insert snip)
|
|
(send button-editor set-clickback 0
|
|
(send button-editor get-end-position)
|
|
(cond
|
|
[(and src-editor partial?)
|
|
(lambda (t s e)
|
|
(send coverage display-covered-portion src-editor src))]
|
|
[src-editor
|
|
(lambda (t s e)
|
|
(send coverage display-coverage src-editor))]
|
|
[else (lambda (t s e) (void))])
|
|
#f #f)
|
|
(send button-editor lock #t)
|
|
(let ([c (new style-delta%)])
|
|
(send c set-delta-foreground "royalblue")
|
|
(send dest change-style c start (sub1 (send dest get-end-position))
|
|
#f))))))
|
|
|
|
(define analysis<%>
|
|
(interface ()
|
|
register-test register-testcase
|
|
de-register-test de-register-testcase
|
|
analyze provide-info))
|
|
|
|
(define coverage-analysis%
|
|
(class* object% (analysis<%>)
|
|
|
|
(define coverage-info (make-object coverage-track%))
|
|
|
|
(define/public (register-test name src)
|
|
(send coverage-info register-coverage-point src))
|
|
(define/public (register-testcase name src)
|
|
(send coverage-info register-coverage-point src))
|
|
(define/public (de-register-test src)
|
|
(send coverage-info unregister-coverage-point src))
|
|
(define/public (de-register-testcase src)
|
|
(send coverage-info unregister-coverage-point src))
|
|
(define/public (analyze src vals)
|
|
(send coverage-info covered-position (list-ref src 3) (list-ref src 4)))
|
|
|
|
(define/public (provide-info) coverage-info)
|
|
(super-instantiate ())))
|