added bug logging
svn: r11528
This commit is contained in:
parent
898edef55e
commit
aaccfbb42f
|
@ -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
|
||||
|
|
|
@ -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^
|
||||
|
|
|
@ -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?)
|
||||
|
|
|
@ -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%
|
||||
|
|
BIN
collects/icons/very-small-planet.png
Normal file
BIN
collects/icons/very-small-planet.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 1.3 KiB |
|
@ -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?]{
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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")
|
||||
|
||||
|
||||
)
|
||||
|
|
Loading…
Reference in New Issue
Block a user