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

* Remove a bunch of additional stuff from the bug-report menu

Browse Source 
* Rewrote `reorder-menus' to remove menus that are left empty
* Solves PR7360

svn: r3052
This commit is contained in:
Eli Barzilay 2006-05-24 23:01:45 +00:00
parent 1d6f7fb541
commit 9ae090e45b
3 changed files with 31 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/framework/private/frame.ss
View File

@ -33,40 +33,29 @@
[scheme : framework:scheme^]
[exit : framework:exit^]
[comment-box : framework:comment-box^])
(rename [-editor<%> editor<%>]
[-pasteboard% pasteboard%]
[-text% text%])
(define (reorder-menus frame)
(let* ([items (send (send frame get-menu-bar) get-items)]
[move-to-back
(λ (name items)
(let loop ([items items]
[back null])
(cond
[(null? items) back]
[else (let ([item (car items)])
(if (string=? (send item get-plain-label) name)
(loop (cdr items)
(cons item back))
(cons item (loop (cdr items) back))))])))]
[move-to-front
(λ (name items)
(reverse (move-to-back name (reverse items))))]
[re-ordered
(move-to-front
(string-constant file-menu)
(move-to-front
(string-constant edit-menu)
(move-to-back
(string-constant help-menu)
(move-to-back
(string-constant windows-menu)
items))))])
(define items (send (send frame get-menu-bar) get-items))
(define (find-menu name)
(ormap (λ (i) (and (string=? (send i get-plain-label) name) i))
items))
(let* ([file-menu (find-menu (string-constant file-menu))]
[edit-menu (find-menu (string-constant edit-menu))]
[windows-menu (find-menu (string-constant windows-menu))]
[help-menu (find-menu (string-constant help-menu))]
[other-items
(remq* (list file-menu edit-menu windows-menu help-menu) items)]
[? (λ (menu) (and menu (pair? (send menu get-items)) menu))]
[re-ordered (filter values `(,(? file-menu) ,(? edit-menu)
,@other-items
,(? windows-menu) ,(? help-menu)))])
(for-each (λ (item) (send item delete)) items)
(for-each (λ (item) (send item restore)) re-ordered)))
(define (add-snip-menu-items edit-menu c%)
(let* ([get-edit-target-object
(λ ()

3
collects/framework/private/standard-menus.ss
View File

@ -159,8 +159,7 @@
(define remove-prefs-callback
(preferences:add-callback
'framework:menu-bindings
(λ
(p v)
(λ (p v)
(let loop ((menu (get-menu-bar)))
(when (is-a? menu menu:can-restore<%>)
(if v (send menu restore-keybinding) (send menu set-shortcut #f)))

26
collects/help/bug-report.ss
View File

@ -22,21 +22,23 @@
;; this one should be defined by help desk.
(define frame-mixin
(namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x))))
(preferences:set-default 'drscheme:email "" string?)
(preferences:set-default 'drscheme:full-name "" string?)
(define (remove-extra-blanks %)
(class %
(define/override (edit-menu:between-find-and-preferences menu) (void))
(super-instantiate ())))
(define bug-frame%
(class (frame-mixin (remove-extra-blanks (frame:standard-menus-mixin frame:basic%)))
(class (frame-mixin (frame:standard-menus-mixin frame:basic%))
(init title)
;; a bunch of stuff we don't want
(define/override (file-menu:between-print-and-close menu) (void))
(define/override (edit-menu:between-find-and-preferences menu) (void))
(define/override (file-menu:create-open?) #f)
(define/override (file-menu:create-open-recent?) #f)
(define/override (file-menu:create-new?) #f)
(define/override (file-menu:create-save?) #f)
(define/override (file-menu:create-revert?) #f)
(field (ok-to-close? #f))
(public set-ok-to-close)
(define (set-ok-to-close ok?) (set! ok-to-close? #t))
@ -45,15 +47,15 @@
(ask-yes-or-no (string-constant cancel-bug-report?)
(string-constant are-you-sure-cancel-bug-report?)
this)))
(super-make-object title)))
(define (help-desk:report-bug)
(define bug-frame (instantiate bug-frame% () (title (string-constant bug-report-form))))
(define single (new panel:single% (parent (send bug-frame get-area-container))))
(define outermost-panel (make-object vertical-panel% single))
(define response-panel (new vertical-panel% (parent single)))
(define response-text (new (html-text-mixin text%) (auto-wrap #t)))
(define response-ec (new editor-canvas% (parent response-panel) (editor response-text)))