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

used capability interface for a bunch more special menu items

Browse Source 
svn: r3205

original commit: c948e8cbc6f9437bbcf824766658497b1fdf5c11
This commit is contained in:
Robby Findler 2006-06-03 19:44:18 +00:00
parent d15b16628a
commit bc61310933
2 changed files with 56 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/framework/framework.ss
View File

@ -666,14 +666,18 @@
"The first argument should be the preferences symbol, and the second an third"
"should be the default width and height, respectively.")
(frame:add-snip-menu-items
((is-a?/c menu%) (subclass?/c menu-item%) . -> . void?)
(menu menu-item%)
(opt-> ((is-a?/c menu%) (subclass?/c menu-item%))
((-> (is-a?/c menu-item%) void?))
void?)
(menu menu-item% func)
"Inserts three menu items into \\var{menu},"
"one that inserts a text box, one that inserts a"
"pasteboard box, and one that inserts an image"
"into the currently focused editor (if there is one)."
"Uses \\var{menu-item\\%} as the class for"
"the menu items.")
"the menu items."
""
"Calls \\var{func} right after inserting each menu item.")
(frame:reorder-menus
((is-a?/c frame%) . -> . void?)

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

@ -62,48 +62,56 @@
(when (pair? (send menu get-items)) (send menu restore)))
menus))
(define (add-snip-menu-items edit-menu c%)
(let* ([get-edit-target-object
(λ ()
(let ([menu-bar
(let loop ([p (send edit-menu get-parent)])
(cond
[(is-a? p menu-bar%)
p]
[(is-a? p menu%)
(loop (send p get-parent))]
[else #f]))])
(and menu-bar
(let ([frame (send menu-bar get-frame)])
(send frame get-edit-target-object)))))]
[edit-menu:do
(λ (const)
(λ (menu evt)
(define add-snip-menu-items
(opt-lambda (edit-menu c% [func void])
(let* ([get-edit-target-object
(λ ()
(let ([menu-bar
(let loop ([p (send edit-menu get-parent)])
(cond
[(is-a? p menu-bar%)
p]
[(is-a? p menu%)
(loop (send p get-parent))]
[else #f]))])
(and menu-bar
(let ([frame (send menu-bar get-frame)])
(send frame get-edit-target-object)))))]
[edit-menu:do
(λ (const)
(λ (menu evt)
(let ([edit (get-edit-target-object)])
(when (and edit
(is-a? edit editor<%>))
(send edit do-edit-operation const)))
#t))]
[on-demand
(λ (menu-item)
(let ([edit (get-edit-target-object)])
(when (and edit
(is-a? edit editor<%>))
(send edit do-edit-operation const)))
#t))]
[on-demand
(λ (menu-item)
(let ([edit (get-edit-target-object)])
(send menu-item enable (and edit (is-a? edit editor<%>)))))]
[insert-comment-box
(λ ()
(let ([text (get-edit-target-object)])
(when text
(let ([snip (make-object comment-box:snip%)])
(send text insert snip)
(send text set-caret-owner snip 'global)))))])
(make-object c% (string-constant insert-comment-box-menu-item-label)
edit-menu
(λ (x y) (insert-comment-box))
#f #f
on-demand)
(make-object c% (string-constant insert-image-item)
edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
(void)))
(send menu-item enable (and edit (is-a? edit editor<%>)))))]
[insert-comment-box
(λ ()
(let ([text (get-edit-target-object)])
(when text
(let ([snip (make-object comment-box:snip%)])
(send text insert snip)
(send text set-caret-owner snip 'global)))))])
(let ([item
(new c%
[label (string-constant insert-comment-box-menu-item-label)]
[parent edit-menu]
[callback (λ (x y) (insert-comment-box))]
[demand-callback on-demand])])
(func item))
(let ([item
(new c%
[label (string-constant insert-image-item)]
[parent edit-menu]
[callback (edit-menu:do 'insert-image)]
[demand-callback on-demand])])
(func item))
(void))))
(define frame-width 600)
(define frame-height 650)