142 lines
5.8 KiB
Scheme
142 lines
5.8 KiB
Scheme
(module test-coverage mzscheme
|
|
|
|
(require (lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(prefix list: (lib "list.ss"))
|
|
(lib "integer-set.ss"))
|
|
|
|
(provide (all-defined))
|
|
|
|
(define coverage-track%
|
|
(class* object% ()
|
|
|
|
(super-instantiate ())
|
|
|
|
(define covered (make-range)) ; interger-set
|
|
(define covered-from-src (make-hash-table 'weak));[hashtable-of scheme-val -> integer-set]
|
|
(define current-coverage-srcs null); (listof covered-from-src keys)
|
|
|
|
(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"))
|
|
(if partial?
|
|
(send button-editor insert "Highlight covered expressions")
|
|
(send button-editor insert "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)
|
|
(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 ())
|
|
))
|
|
|
|
|
|
|
|
) |