suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed test case coverage and debugging (the latter only when the file isn't saved)

Browse Source 
svn: r8423
This commit is contained in:
Robby Findler 2008-01-26 13:52:20 +00:00
parent 3c912d18b2
commit 765a40a2ea
1 changed files with 57 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
collects/drscheme/private/debug.ss
View File

@ -33,7 +33,7 @@ profile todo:
(export drscheme:debug^) (export drscheme:debug^)
(define (oprintf . args) (apply fprintf orig args)) (define (printf . args) (apply fprintf orig args))
; ;
@ -420,7 +420,17 @@ profile todo:
(syntax-source src-stx)] (syntax-source src-stx)]
[(is-a? (syntax-source src-stx) editor<%>) [(is-a? (syntax-source src-stx) editor<%>)
(syntax-source src-stx)] (syntax-source src-stx)]
[else #f])] [else
(let* ([rep (drscheme:rep:current-rep)])
(and
rep
(let ([defs (send rep get-definitions-text)])
(cond
[(send rep port-name-matches? (syntax-source src-stx))
rep]
[(send defs port-name-matches? (syntax-source src-stx))
defs]
[else #f]))))])]
[position (or (syntax-position src-stx) 0)] [position (or (syntax-position src-stx) 0)]
[span (or (syntax-span src-stx) 0)] [span (or (syntax-span src-stx) 0)]
[line (or (syntax-line src-stx) 0)] [line (or (syntax-line src-stx) 0)]
@ -897,49 +907,49 @@ profile todo:
[actions-ht (make-hash-table 'equal)] [actions-ht (make-hash-table 'equal)]
[on/syntaxes (hash-table-map ht (λ (_ pr) pr))] [on/syntaxes (hash-table-map ht (λ (_ pr) pr))]
;; can-annotate : (listof (list boolean syntax)) ;; can-annotate : (listof (list boolean srcloc))
;; boolean is #t => code was run ;; boolean is #t => code was run
;; #f => code was not run ;; #f => code was not run
;; remove those that cannot be annotated ;; remove those that cannot be annotated
[can-annotate [can-annotate
(filter (λ (pr) (filter values
(let ([stx (mcdr pr)]) (map (λ (pr)
(and (syntax? stx) (let ([stx (mcdr pr)])
(let ([src (syntax-source stx)] (and (syntax? stx)
[pos (syntax-position stx)] (let ([src (syntax-source stx)]
[span (syntax-span stx)]) [pos (syntax-position stx)]
(and (is-a? src text:basic<%>) [span (syntax-span stx)])
pos (and pos
span))))) span
on/syntaxes)] (send (get-defs) port-name-matches? src)
(list (mcar pr) (make-srcloc (get-defs) #f #f pos span)))))))
on/syntaxes))]
;; filtered : (listof (list boolean syntax)) ;; filtered : (listof (list boolean srcloc))
;; remove redundant expressions ;; remove redundant expressions
[filtered [filtered
(let (;; actions-ht : (list src number number) -> (list boolean syntax) (let (;; actions-ht : (list src number number) -> (list boolean syntax)
[actions-ht (make-hash-table 'equal)]) [actions-ht (make-hash-table 'equal)])
(for-each (for-each
(λ (pr) (λ (pr)
(let* ([stx (mcdr pr)] (let* ([on? (list-ref pr 0)]
[on? (mcar pr)] [key (list-ref pr 1)]
[key (list (syntax-source stx) [old (hash-table-get actions-ht key 'nothing)])
(syntax-position stx)
(syntax-span stx))]
[old (hash-table-get actions-ht key (λ () 'nothing))])
(cond (cond
[(eq? old 'nothing) (hash-table-put! actions-ht key (list on? stx))] [(eq? old 'nothing) (hash-table-put! actions-ht key on?)]
[(car old) ;; recorded as executed [old ;; recorded as executed
(void)] (void)]
[(not (car old)) ;; recorded as unexected [(not old) ;; recorded as unexected
(when on? (when on?
(hash-table-put! actions-ht key (list #t stx)))]))) (hash-table-put! actions-ht key #t))])))
can-annotate) can-annotate)
(hash-table-map actions-ht (λ (k v) v)))]) (hash-table-map actions-ht (λ (k v) (list v k))))])
;; if everything is covered *and* no coloring has been done, do no coloring. ;; if everything is covered *and* no coloring has been done, do no coloring.
(unless (and (andmap car filtered) (unless (and (andmap car filtered)
(not (get-test-coverage-info-visible?))) (not (get-test-coverage-info-visible?)))
(let (;; sorted : (listof (list boolean syntax))
(let (;; sorted : (listof (list boolean srcloc))
;; sorting predicate: ;; sorting predicate:
;; x < y if ;; x < y if
;; x's span is bigger than y's (ie, do larger expressions first) ;; x's span is bigger than y's (ie, do larger expressions first)
@ -949,14 +959,14 @@ profile todo:
(sort (sort
filtered filtered
(λ (x y) (λ (x y)
(let* ([x-stx (cadr x)] (let* ([x-on (list-ref x 0)]
[y-stx (cadr y)] [y-on (list-ref y 0)]
[x-pos (syntax-position x-stx)] [x-srcloc (list-ref x 1)]
[y-pos (syntax-position y-stx)] [y-srcloc (list-ref y 1)]
[x-span (syntax-span x-stx)] [x-pos (srcloc-position x-srcloc)]
[y-span (syntax-span y-stx)] [y-pos (srcloc-position y-srcloc)]
[x-on (car x)] [x-span (srcloc-span x-srcloc)]
[y-on (car y)]) [y-span (srcloc-span y-srcloc)])
(cond (cond
[(and (= x-pos y-pos) [(and (= x-pos y-pos)
(= x-span x-span)) (= x-span x-span))
@ -968,7 +978,7 @@ profile todo:
;; also fill in the edit-sequence-ht ;; also fill in the edit-sequence-ht
(for-each (for-each
(λ (pr) (λ (pr)
(let ([src (syntax-source (cadr pr))]) (let ([src (srcloc-source (list-ref pr 1))])
(hash-table-get (hash-table-get
edit-sequence-ht edit-sequence-ht
src src
@ -996,19 +1006,18 @@ profile todo:
;; set new annotations ;; set new annotations
(for-each (for-each
(λ (pr) (λ (pr)
(let ([stx (cadr pr)] (let ([on? (list-ref pr 0)]
[on? (car pr)]) [srcloc (list-ref pr 1)])
(when (syntax? stx) (let* ([src (srcloc-source srcloc)]
(let* ([src (syntax-source stx)] [pos (srcloc-position srcloc)]
[pos (syntax-position stx)] [span (srcloc-span srcloc)])
[span (syntax-span stx)]) (send src change-style
(send src change-style (if on?
(if on? (or on-style test-covered-style-delta)
(or on-style test-covered-style-delta) (or off-style test-not-covered-style-delta))
(or off-style test-not-covered-style-delta)) (- pos 1)
(- pos 1) (+ (- pos 1) span)
(+ (- pos 1) span) #f))))
#f)))))
sorted) sorted)
;; relock editors ;; relock editors