added bug logging

svn: r11528
This commit is contained in:
Robby Findler 2008-09-02 21:34:56 +00:00
parent 898edef55e
commit aaccfbb42f
8 changed files with 396 additions and 128 deletions

View File

@ -23,6 +23,7 @@ profile todo:
net/sendurl
net/url
scheme/match
mrlib/include-bitmap
(for-syntax scheme/base))
(define orig (current-output-port))
@ -171,26 +172,23 @@ profile todo:
(super-make-object str)))
;; make-note% : string -> (union class #f)
(define (make-note% filename flag)
(let ([bitmap (make-object bitmap%
(build-path (collection-path "icons") filename)
flag)])
(and (send bitmap ok?)
(letrec ([note%
(class clickable-image-snip%
(inherit get-callback)
(define/public (get-image-name) filename)
(define/override (copy)
(let ([n (new note%)])
(send n set-callback (get-callback))
n))
(super-make-object bitmap))])
note%))))
(define (make-note% filename bitmap)
(and (send bitmap ok?)
(letrec ([note%
(class clickable-image-snip%
(inherit get-callback)
(define/public (get-image-name) filename)
(define/override (copy)
(let ([n (new note%)])
(send n set-callback (get-callback))
n))
(super-make-object bitmap))])
note%)))
(define bug-note% (make-note% "stop-multi.png" 'png/mask))
(define mf-note% (make-note% "mf.gif" 'gif))
(define file-note% (make-note% "stop-22x22.png" 'png/mask))
(define planet-note% (make-note% "small-planet.png" 'png/mask))
(define bug-note% (make-note% "stop-multi.png" (include-bitmap (lib "icons/stop-multi.png") 'png/mask)))
(define mf-note% (make-note% "mf.gif" (include-bitmap (lib "icons/mf.gif") 'gif)))
(define file-note% (make-note% "stop-22x22.png" (include-bitmap (lib "icons/stop-22x22.png") 'png/mask)))
(define planet-note% (make-note% "small-planet.png" (include-bitmap (lib "icons/small-planet.png") 'png/mask)))
;; display-stats : (syntax -> syntax)
;; count the number of syntax expressions & number of with-continuation-marks in an
@ -273,6 +271,7 @@ profile todo:
debug-error-display-handler)
;; error-display-handler/stacktrace : string any (listof srcloc) -> void
;; =User=
(define (error-display-handler/stacktrace msg exn [pre-stack #f])
(let* ([stack (or pre-stack
(if (exn? exn)
@ -303,47 +302,63 @@ profile todo:
;; and still running here?
(send rep highlight-errors src-locs stack))))))))
;; =User=
(define (print-planet-icon-to-stderr exn)
(when (exn:fail:contract2? exn)
(let ([gp-url (parse-gp exn (guilty-party exn))])
(when gp-url
(when planet-note%
(when (port-writes-special? (current-error-port))
(let ([note (new planet-note%)])
(send note set-callback (λ () (send-url (url->string gp-url))))
(write-special note (current-error-port))
(display #\space (current-error-port)))))))))
(let ([table (parse-gp exn (guilty-party exn))])
(when table
(let ([gp-url (bug-info->ticket-url table)])
(when planet-note%
(when (port-writes-special? (current-error-port))
(let ([note (new planet-note%)])
(send note set-callback (λ ()
;; =Kernel= =Handler=
(drscheme:unit:forget-saved-bug-report table)
(send-url (url->string gp-url))))
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(queue-callback
(λ ()
(drscheme:unit:record-saved-bug-report table))))
(write-special note (current-error-port))
(display #\space (current-error-port))))))))))
;; =Kernel= =User=
(define (bug-info->ticket-url table)
(make-url
"http"
#f
"planet.plt-scheme.org"
#f
#t
(list (make-path/param "trac" '())
(make-path/param "newticket" '()))
table
#f))
;; =User=
(define (parse-gp exn gp)
(match gp
[`(planet ,fn (,user ,package ,version ...))
(make-url
"http"
#f
"planet.plt-scheme.org"
#f
#t
(list (make-path/param "trac" '())
(make-path/param "newticket" '()))
(list (cons 'component (format "~a/~a" user package))
(cons 'keywords "contract violation")
(cons 'planetversion
(cond
[(null? version) ""]
[(null? (cdr version))
(format "~s" `(,(car version) ?))]
[else
(format "~s" `(,(car version) ,(cadr version)))]))
(cons 'description (exn->trace exn)))
#f)]
(list (cons 'component (format "~a/~a" user package))
(cons 'keywords "contract violation")
(cons 'planetversion
(cond
[(null? version) ""]
[(null? (cdr version))
(format "~s" `(,(car version) ?))]
[else
(format "~s" `(,(car version) ,(cadr version)))]))
(cons 'description (exn->trace exn)))]
[else #f]))
;; =User=
(define (exn->trace exn)
(let ([sp (open-output-string)])
(parameterize ([current-error-port sp])
(drscheme:init:original-error-display-handler (exn-message exn) exn))
(get-output-string sp)))
;; =User=
(define (print-bug-to-stderr msg cms)
(when (port-writes-special? (current-error-port))
(let ([note% (if (mf-bday?) mf-note% bug-note%)])
@ -842,9 +857,6 @@ profile todo:
;
;
;
@ -1233,7 +1245,7 @@ profile todo:
;; initialize-profile-point : sym syntax syntax -> void
;; called during compilation to register this point as
;; a profile point.
;; =user=
;; =User=
;; imported into errortrace
(define (initialize-profile-point key name expr)
(unless (thread-cell-ref current-profile-info)
@ -1252,7 +1264,7 @@ profile todo:
(void))
;; register-profile-start : sym -> (union #f number)
;; =user=
;; =User=
;; imported into errortrace
(define (register-profile-start key)
(let ([ht (thread-cell-ref current-profile-info)])
@ -1266,7 +1278,7 @@ profile todo:
(current-process-milliseconds)))))))
;; register-profile-done : sym (union #f number) -> void
;; =user=
;; =User=
;; imported into errortrace
(define (register-profile-done key start)
(when start

View File

@ -53,7 +53,7 @@
(make-debug-error-display-handler
make-debug-eval-handler
error-display-handler/stacktrace
bug-info->ticket-url
test-coverage-enabled
profiling-enabled
@ -157,6 +157,8 @@
find-symbol
get-program-editor-mixin
add-to-program-editor-mixin
forget-saved-bug-report
record-saved-bug-report
(struct teachpack-callbacks (get-names remove add))))
(define-signature drscheme:frame-cm^

View File

@ -53,6 +53,19 @@
(finder:default-filters)))
(application:current-app-name (string-constant drscheme))
(preferences:set-default 'drscheme:saved-bug-reports
'()
(λ (ll)
(and (list? ll)
(andmap
(λ (l)
(and (list? l)
(andmap (λ (x) (and (pair? x)
(symbol? (car x))
(string? (cdr x))))
l)))
ll))))
(preferences:set-default 'drscheme:module-language-first-line-special? #t boolean?)
(preferences:set-default 'drscheme:defns-popup-sort-by-name? #f boolean?)

View File

@ -28,7 +28,11 @@ module browser threading seems wrong.
"insert-large-letters.ss"
mrlib/switchable-button
mrlib/cache-image-snip
mrlib/include-bitmap
net/sendurl
net/url
(prefix-in drscheme:arrow: "../arrow.ss")
mred
@ -58,7 +62,8 @@ module browser threading seems wrong.
[prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:init: drscheme:init^]
[prefix drscheme:module-language: drscheme:module-language^]
[prefix drscheme:modes: drscheme:modes^])
[prefix drscheme:modes: drscheme:modes^]
[prefix drscheme:debug: drscheme:debug^])
(export (rename drscheme:unit^
[-frame% frame%]
[-frame<%> frame<%>]))
@ -847,20 +852,24 @@ module browser threading seems wrong.
; ; ;; ;
; ; ;
; ; ;
; ;;; ; ;;; ;;; ; ; ;;; ;;;
; ; ;; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;;;; ; ; ; ; ;;;;;
; ; ; ; ; ; ; ; ;
; ; ;; ; ; ; ; ; ;
; ;;; ; ;;;; ; ; ; ; ;;;; ; ; ;
;
;
;
;
;
;
; ;;; ;;;;;;;
; ;;; ;;;
; ;; ;;; ;;;; ;;;;; ;;; ;;; ;; ;;;;
; ;;;;;;; ;; ;;;;;;;; ;;; ;;;;;;; ;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;;;;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;;
; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;;
;
;
;
;
;; get-pos : text mouse-event% -> (union #f number)
(define (get-pos text event)
@ -1120,19 +1129,25 @@ module browser threading seems wrong.
;;
;
;
;;; ; ;; ;;; ; ;;; ;; ;;;
; ;; ; ; ;; ;; ; ; ;
; ; ; ; ; ; ; ;
; ; ;;;; ; ; ; ;;;;;
; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;
; ; ;;;;; ; ; ; ;;;;
;
;
;
;
; ;;;;
; ;;;
; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;;
; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;;
; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;
; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;;
;
;
;
;
(define dragable/def-int-mixin
(mixin (panel:dragable<%>) ()
(init-field unit-frame)
@ -1332,6 +1347,8 @@ module browser threading seems wrong.
register-toolbar-button
get-tabs))
(define frame-mixin
(mixin (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
(-frame<%>)
@ -1841,6 +1858,7 @@ module browser threading seems wrong.
[else (send definitions-text clear)])
(send definitions-canvas focus))
@ -2262,6 +2280,7 @@ module browser threading seems wrong.
(when logging
(stop-logging))
(remove-show-status-line-callback)
(remove-bug-icon-callback)
(send interactions-text on-close))
;; execute-callback : -> void
@ -3568,6 +3587,30 @@ module browser threading seems wrong.
(define running-canvas
(new running-canvas% [parent (get-info-panel)]))
(define bug-icon
(let* ([info-panel (get-info-panel)]
[btn
(new switchable-button%
[parent info-panel]
[callback (λ (x) (show-saved-bug-reports-window))]
[bitmap very-small-planet-bitmap]
[vertical-tight? #t]
[label (string-constant show-planet-contract-violations)])])
(send btn set-label-visible #f)
(send info-panel change-children
(λ (l)
(cons btn (remq* (list btn) l))))
btn))
(define/private (set-bug-label v)
(if (null? v)
(send bug-icon show #f)
(send bug-icon show #t)))
(set-bug-label (preferences:get 'drscheme:saved-bug-reports))
(define remove-bug-icon-callback
(preferences:add-callback
'drscheme:saved-bug-reports
(λ (p v)
(set-bug-label v))))
[define func-defs-canvas (new func-defs-canvas%
(parent name-panel)
@ -3640,6 +3683,26 @@ module browser threading seems wrong.
(set! newest-frame this)
(send definitions-canvas focus)))
;
;
;
;
; ;;;
;
; ;;; ;;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;; ;; ;;;
; ;;;;;;;; ;;; ;;;;;;; ;;;;;;; ;;; ;;;;;;; ;;;;;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;;
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;;
; ;;;
; ;;;;;;
;
;
(define running-bitmap (include-bitmap (lib "icons/b-run.png")))
(define waiting-bitmap (include-bitmap (lib "icons/b-wait.png")))
(define waiting2-bitmap (include-bitmap (lib "icons/b-wait2.png")))
@ -3902,6 +3965,166 @@ module browser threading seems wrong.
(inherit set-allow-shrinking)
(set-allow-shrinking 100)))
;
;
;
;
; ;;; ;
; ;;; ;;;
; ;;; ;; ;;; ;;; ;; ;;; ;;; ;; ;;;; ;;; ;; ;;; ;;; ;;;;; ;;;;
; ;;;;;;; ;;; ;;; ;;;;;;; ;;;;; ;; ;;; ;;;;;;; ;;;;; ;;;;;;;;; ;;; ;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;;;;;;; ;;;;;;; ;;;;;;; ;;; ;;;;;; ;;;;;;; ;;;;; ;;; ;;;; ;; ;;;
; ;;; ;; ;; ;;; ;; ;;; ;;; ;;;; ;;; ;; ;;; ;;; ;;; ;;;;
; ;;; ;;;
; ;;;;;; ;;;
;
;
;; record-saved-bug-report : (listof (cons symbol string)) -> void
;; =Kernel= =Handler=
(define (record-saved-bug-report table)
(let ([recorded (preferences:get 'drscheme:saved-bug-reports)])
(unless (member table recorded)
(preferences:set 'drscheme:saved-bug-reports (shorten-to (cons table recorded) 15)))))
;; shorten-to : (listof X) number -> (listof X)
;; drops items from the end of the list to bring it back down to `n' items
(define (shorten-to l n)
(let loop ([l l]
[n n])
(cond
[(zero? n) '()]
[(null? l) '()]
[else (cons (car l) (loop (cdr l) (- n 1)))])))
(define very-small-planet-bitmap (include-bitmap (lib "icons/very-small-planet.png") 'png/mask))
(define saved-bug-reports-window #f)
(define saved-bug-reports-panel #f)
(define (init-saved-bug-reports-window)
(unless saved-bug-reports-window
(let ()
(define stupid-internal-define-syntax1
(set! saved-bug-reports-window (new frame:basic% [label (string-constant drscheme)] [width 600])))
(define stupid-internal-define-syntax2
(set! saved-bug-reports-panel
(new vertical-panel% [parent (send saved-bug-reports-window get-area-container)])))
(define hp (new horizontal-panel%
[parent (send saved-bug-reports-window get-area-container)]
[stretchable-width #f]
[alignment '(right center)]))
(define forget-all (new button%
[label (string-constant bug-track-forget-all)]
[callback
(λ (_1 _2)
(send saved-bug-reports-window show #f)
(preferences:set 'drscheme:saved-bug-reports '()))]
[parent hp]))
(void))))
(preferences:add-callback
'drscheme:saved-bug-reports
(λ (p v)
(when saved-bug-reports-window
(when (send saved-bug-reports-window is-shown?)
(cond
[(null? v)
(send saved-bug-reports-window show #f)]
[else
(refresh-saved-bug-reports-window v)])))))
(define (refresh-saved-bug-reports-window pref)
(send saved-bug-reports-window begin-container-sequence)
(send saved-bug-reports-panel change-children (λ (l) '()))
(for-each
(λ (item)
(let ()
(define (lookup k [default ""])
(let loop ([item item])
(cond
[(null? item) default]
[else (let ([rib (car item)])
(if (eq? (car rib) k)
(cdr rib)
(loop (cdr item))))])))
(define vp
(new vertical-panel%
[style '(border)]
[parent saved-bug-reports-panel]
[stretchable-height #f]))
(define hp
(new horizontal-panel%
[parent vp]
[stretchable-height #f]))
(define first-line-msg
(let ([desc (lookup 'description #f)])
(and desc
(new message%
[label (read-line (open-input-string desc))]
[parent vp]
[stretchable-width #t]
[font (send (send (editor:get-standard-style-list) find-named-style "Standard") get-font)]))))
(define msg (new message%
[stretchable-width #t]
[label (string-append (lookup 'component "<<unknown component>>")
(let ([v (lookup 'version #f)])
(if v
(string-append " " v)
"")))]
[parent hp]))
(define forget (new button%
[parent hp]
[callback (λ (x y) (forget-saved-bug-report item))]
[label (string-constant bug-track-forget)]))
(define report (new button%
[parent hp]
[callback (λ (x y)
(forget-saved-bug-report item)
(send-url
(url->string
(drscheme:debug:bug-info->ticket-url item))))]
[label (string-constant bug-track-report)]))
(void)))
pref) ;; reverse list so first elements end up on top of list
(send saved-bug-reports-window reflow-container)
(send saved-bug-reports-window end-container-sequence))
(define (forget-saved-bug-report item)
(preferences:set 'drscheme:saved-bug-reports (remove item (preferences:get 'drscheme:saved-bug-reports))))
(define (show-saved-bug-reports-window)
(init-saved-bug-reports-window)
(unless (send saved-bug-reports-window is-shown?)
(refresh-saved-bug-reports-window (preferences:get 'drscheme:saved-bug-reports)))
(send saved-bug-reports-window show #t))
;
;
;
;
; ;;;; ;; ;
; ;;; ; ; ;
; ;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; ; ; ;
; ;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ; ; ;
; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;;
; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ; ; ;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ; ; ;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ; ; ;
; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; ; ;;
;
;
;
;
(define -frame% (frame-mixin super-frame%))
(define module-browser-dragable-panel%

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.3 KiB

View File

@ -16,8 +16,8 @@ label and the icon side-by-side.
@defconstructor/auto-super[([label string?]
[callback (-> (is-a?/c switchable-button%) any/c)]
[bitmap (is-a?/c bitmap%)]
[alternate-bitmap (is-a?/c bitmap%) bitmap]
)]{
[alternate-bitmap (is-a?/c bitmap%) bitmap]
[vertical-tight? boolean? #f])]{
The @scheme[callback] is called when the button
is pressed. The @scheme[string] and @scheme[bitmap] are
used as discussed above.
@ -25,6 +25,9 @@ used as discussed above.
If @scheme[alternate-bitmap] is supplied, then it is used
when the button is switched to the view that just shows the bitmap.
If it is not supplied, both modes show the same bitmap.
If the @scheme[vertical-tight?] argument is @scheme[#t], then the button takes up
as little as possible vertical space.
}
@defmethod[(set-label-visible [visible? boolean?]) void?]{

View File

@ -53,7 +53,8 @@
(init-field label
bitmap
callback
[alternate-bitmap bitmap])
[alternate-bitmap bitmap]
[vertical-tight? #f])
(define/override (get-label) label)
@ -70,7 +71,7 @@
(define down? #f)
(define in? #f)
(define disabled? #f)
(define with-label? #t)
(define with-label? (string? label))
(define/override (enable e?)
(unless (equal? disabled? (not e?))
@ -122,47 +123,48 @@
(define timer-running? #f)
(define/private (update-float new-value?)
(cond
[with-label?
(when float-window
(send float-window show #f))]
[else
(unless (and float-window
(equal? new-value? (send float-window is-shown?)))
(cond
[in?
(unless float-window
(set! float-window (new frame%
[label ""]
[style '(no-caption no-resize-border float)]
[stretchable-width #f]
[stretchable-height #f]))
(new yellow-message% [parent float-window] [label label]))
(send float-window reflow-container)
;; position the floating window
(let-values ([(dw dh) (get-display-size)]
[(x y) (client->screen (floor (get-width))
(floor
(- (/ (get-height) 2)
(/ (send float-window get-height) 2))))]
[(dx dy) (get-display-left-top-inset)])
(let ([rhs-x (- x dx)]
[rhs-y (- y dy)])
(cond
[(< (+ rhs-x (send float-window get-width)) dw)
(send float-window move rhs-x rhs-y)]
[else
(send float-window move
(- rhs-x (send float-window get-width) (get-width))
rhs-y)])))
(unless timer-running?
(set! timer-running? #t)
(send timer start 500 #t))]
[else
(when float-window
(send float-window show #f))]))]))
(when label
(cond
[with-label?
(when float-window
(send float-window show #f))]
[else
(unless (and float-window
(equal? new-value? (send float-window is-shown?)))
(cond
[in?
(unless float-window
(set! float-window (new frame%
[label ""]
[style '(no-caption no-resize-border float)]
[stretchable-width #f]
[stretchable-height #f]))
(new yellow-message% [parent float-window] [label (or label "")]))
(send float-window reflow-container)
;; position the floating window
(let-values ([(dw dh) (get-display-size)]
[(x y) (client->screen (floor (get-width))
(floor
(- (/ (get-height) 2)
(/ (send float-window get-height) 2))))]
[(dx dy) (get-display-left-top-inset)])
(let ([rhs-x (- x dx)]
[rhs-y (- y dy)])
(cond
[(< (+ rhs-x (send float-window get-width)) dw)
(send float-window move rhs-x rhs-y)]
[else
(send float-window move
(- rhs-x (send float-window get-width) (get-width))
rhs-y)])))
(unless timer-running?
(set! timer-running? #t)
(send timer start 500 #t))]
[else
(when float-window
(send float-window show #f))]))])))
(define/private (update-in evt)
(let-values ([(cw ch) (get-client-size)])
@ -260,7 +262,8 @@
(let ([w (floor (inexact->exact w))]
[h (floor (inexact->exact h))])
(min-width (+ w w-circle-space margin margin))
(min-height (+ h h-circle-space margin margin))))
(min-height (+ h h-circle-space margin margin
(if vertical-tight? -6 0)))))
(super-new [style '(transparent no-focus)])
(send (get-dc) set-smoothing 'aligned)

View File

@ -1406,4 +1406,16 @@ please adhere to these guidelines:
(gui-tool-show-gui-toolbar "Show GUI Toolbar")
(gui-tool-hide-gui-toolbar "Hide GUI Toolbar")
(gui-tool-insert-gui "Insert GUI")
;; contract violation tracking
; tooltip for new planet icon in drscheme window (must have a planet violation logged to see it)
(show-planet-contract-violations "Show PLaneT contract violations")
; buttons in the dialog that lists the recorded bug reports
(bug-track-report "File Ticket")
(bug-track-forget "Forget")
(bug-track-forget-all "Forget All")
)