386 lines
16 KiB
Scheme
386 lines
16 KiB
Scheme
(module standard-menus-items mzscheme
|
|
|
|
(provide
|
|
(struct generic (name initializer))
|
|
|
|
(struct generic/docs (documentation))
|
|
|
|
(struct generic-override ())
|
|
(struct generic-augment ())
|
|
(struct generic-method ())
|
|
(struct generic-private-field ())
|
|
|
|
(struct menu-item (menu-name))
|
|
menu-name->get-menu-name ;; : menu-item -> symbol
|
|
|
|
(struct before/after (name procedure))
|
|
(struct before ())
|
|
(struct after ())
|
|
|
|
(struct between (before after procedure))
|
|
|
|
(struct an-item (item-name help-string proc key menu-string on-demand create))
|
|
(struct a-submenu-item ())
|
|
|
|
;; an-item -> symbol
|
|
;; calcualates the names of various identifiers associated with the item.
|
|
an-item->callback-name
|
|
an-item->create-menu-item-name
|
|
an-item->get-item-name
|
|
an-item->item-name
|
|
an-item->on-demand-name
|
|
an-item->string-name
|
|
an-item->help-string-name
|
|
|
|
before/after->name
|
|
between->name
|
|
|
|
items)
|
|
|
|
(define-struct generic (name initializer))
|
|
(define-struct (generic/docs generic) (documentation))
|
|
(define-struct (generic-override generic/docs) ())
|
|
(define-struct (generic-augment generic/docs) ())
|
|
(define-struct (generic-method generic/docs) ())
|
|
(define-struct (generic-private-field generic) ())
|
|
|
|
(define-struct menu-item (menu-name))
|
|
(define (menu-name->get-menu-name menu-item)
|
|
(string->symbol
|
|
(format "get-~a" (menu-item-menu-name menu-item))))
|
|
|
|
(define-struct (before/after menu-item) (name procedure))
|
|
(define-struct (before before/after) ())
|
|
(define-struct (after before/after) ())
|
|
(define (before/after->name before/after)
|
|
(string->symbol (format "~a:~a-~a"
|
|
(menu-item-menu-name before/after)
|
|
(if (before? before/after)
|
|
"before"
|
|
"after")
|
|
(before/after-name before/after))))
|
|
|
|
(define-struct (between menu-item) (before after procedure))
|
|
(define (between->name between)
|
|
(string->symbol (format "~a:between-~a-and-~a"
|
|
(menu-item-menu-name between)
|
|
(between-before between)
|
|
(between-after between))))
|
|
|
|
(define-struct (an-item menu-item)
|
|
(item-name
|
|
help-string
|
|
proc
|
|
key
|
|
menu-string
|
|
on-demand
|
|
create))
|
|
(define-struct (a-submenu-item an-item) ())
|
|
|
|
(define (an-item->callback-name item)
|
|
(string->symbol
|
|
(format "~a:~a-callback" (menu-item-menu-name item) (an-item-item-name item))))
|
|
(define (an-item->create-menu-item-name item)
|
|
(string->symbol
|
|
(format "~a:create-~a?" (menu-item-menu-name item) (an-item-item-name item))))
|
|
(define (an-item->get-item-name item)
|
|
(string->symbol
|
|
(format "~a:get-~a-item" (menu-item-menu-name item) (an-item-item-name item))))
|
|
(define (an-item->item-name item)
|
|
(string->symbol
|
|
(format "~a:~a-item" (menu-item-menu-name item) (an-item-item-name item))))
|
|
(define (an-item->on-demand-name item)
|
|
(string->symbol
|
|
(format "~a:~a-on-demand" (menu-item-menu-name item) (an-item-item-name item))))
|
|
(define (an-item->string-name item)
|
|
(string->symbol
|
|
(format "~a:~a-string" (menu-item-menu-name item) (an-item-item-name item))))
|
|
(define (an-item->help-string-name item)
|
|
(string->symbol
|
|
(format "~a:~a-help-string" (menu-item-menu-name item) (an-item-item-name item))))
|
|
|
|
(define (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))
|
|
|
|
(define (edit-menu:can-do-on-demand const)
|
|
`(λ (item)
|
|
(let* ([editor (get-edit-target-object)]
|
|
[enable?
|
|
(and editor
|
|
(is-a? editor editor<%>)
|
|
(send editor can-do-edit-operation? ',const))])
|
|
(send item enable enable?))))
|
|
|
|
(define edit-menu:edit-target-on-demand
|
|
`(λ (item)
|
|
(send item enable
|
|
(let ([target (get-edit-target-object)])
|
|
(and target (is-a? target editor<%>))))))
|
|
|
|
(define on-demand-do-nothing '(λ (menu-item) (void)))
|
|
|
|
(define items
|
|
(list (make-generic-augment
|
|
'on-close
|
|
'(lambda ()
|
|
(remove-prefs-callback)
|
|
(inner (void) on-close))
|
|
'("@return : void"
|
|
"Removes the preferences callbacks for the menu items"))
|
|
(make-generic-method
|
|
'get-menu% '(λ () menu:can-restore-underscore-menu%)
|
|
'("The result of this method is used as the class"
|
|
"for creating the result of these methods:"
|
|
"@ilink frame:standard-menus get-file-menu %"
|
|
", "
|
|
"@ilink frame:standard-menus get-edit-menu %"
|
|
", "
|
|
"@ilink frame:standard-menus get-help-menu %"
|
|
". "
|
|
""
|
|
"@return : (derived-from \\iscmclass{menu:can-restore-underscore-menu})"
|
|
""
|
|
"defaultly returns"
|
|
"@link menu"))
|
|
(make-generic-method
|
|
'get-menu-item% '(λ () menu:can-restore-menu-item%)
|
|
'("The result of this method is used as the class for creating"
|
|
"the menu items in this frame (see "
|
|
"@link frame:standard-menus"
|
|
"for a list)."
|
|
""
|
|
"@return : (derived-from \\iscmclass{menu-item})"
|
|
""
|
|
"defaultly returns"
|
|
"@link menu:can-restore-menu-item %"
|
|
"."))
|
|
(make-generic-method
|
|
'get-checkable-menu-item% '(λ () menu:can-restore-checkable-menu-item%)
|
|
'("The result of this method is used as the class for creating"
|
|
"checkable menu items in this class (see "
|
|
"@link frame:standard-menus"
|
|
"for a list)."
|
|
""
|
|
"@return : (derived-from \\iscmclass{checkable-menu-item})"
|
|
""
|
|
"defaultly returns"
|
|
"@link menu:can-restore-checkable-menu-item %"
|
|
"."))
|
|
|
|
(make-generic-method
|
|
'get-file-menu
|
|
'(λ () file-menu)
|
|
'("Returns the file menu"
|
|
"See also"
|
|
"@ilink frame:standard-menus get-menu\\%"
|
|
""
|
|
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
|
(make-generic-private-field
|
|
'file-menu
|
|
'(make-object (get-menu%)
|
|
(string-constant file-menu-label)
|
|
(get-menu-bar)))
|
|
(make-generic-method
|
|
'get-edit-menu
|
|
'(λ () edit-menu)
|
|
|
|
'("Returns the edit menu"
|
|
"See also"
|
|
"@ilink frame:standard-menus get-menu\\%"
|
|
""
|
|
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
|
(make-generic-private-field
|
|
'edit-menu
|
|
'(make-object (get-menu%) (string-constant edit-menu-label) (get-menu-bar)))
|
|
(make-generic-method
|
|
'get-help-menu
|
|
'(λ () help-menu)
|
|
|
|
'("Returns the help menu"
|
|
"See also"
|
|
"@ilink frame:standard-menus get-menu\\%"
|
|
""
|
|
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
|
(make-generic-private-field
|
|
'help-menu
|
|
'(make-object (get-menu%) (string-constant help-menu-label) (get-menu-bar)))
|
|
|
|
(make-an-item 'file-menu 'new
|
|
'(string-constant new-info)
|
|
'(λ (item control) (handler:edit-file #f) #t)
|
|
#\n
|
|
'(string-constant new-menu-item)
|
|
on-demand-do-nothing
|
|
#t)
|
|
(make-between 'file-menu 'new 'open 'nothing)
|
|
(make-an-item 'file-menu 'open '(string-constant open-info)
|
|
'(λ (item control) (handler:open-file) #t)
|
|
#\o
|
|
'(string-constant open-menu-item)
|
|
on-demand-do-nothing
|
|
#t)
|
|
(make-a-submenu-item 'file-menu 'open-recent
|
|
'(string-constant open-recent-info)
|
|
'(λ (x y) (void))
|
|
#f
|
|
'(string-constant open-recent-menu-item)
|
|
'(λ (menu)
|
|
(handler:install-recent-items menu))
|
|
#t)
|
|
(make-between 'file-menu 'open 'revert 'nothing)
|
|
(make-an-item 'file-menu 'revert
|
|
'(string-constant revert-info)
|
|
'(λ (item control) (void))
|
|
#f
|
|
'(string-constant revert-menu-item)
|
|
on-demand-do-nothing
|
|
#f)
|
|
(make-between 'file-menu 'revert 'save 'nothing)
|
|
(make-an-item 'file-menu 'save
|
|
'(string-constant save-info)
|
|
'(λ (item control) (void))
|
|
#\s
|
|
'(string-constant save-menu-item)
|
|
on-demand-do-nothing
|
|
#f)
|
|
(make-an-item 'file-menu 'save-as
|
|
'(string-constant save-as-info)
|
|
'(λ (item control) (void))
|
|
#f
|
|
'(string-constant save-as-menu-item)
|
|
on-demand-do-nothing
|
|
#f)
|
|
(make-between 'file-menu 'save-as 'print 'nothing)
|
|
(make-an-item 'file-menu 'print
|
|
'(string-constant print-info)
|
|
'(λ (item control) (void))
|
|
#\p
|
|
'(string-constant print-menu-item)
|
|
on-demand-do-nothing
|
|
#f)
|
|
(make-between 'file-menu 'print 'close 'separator)
|
|
(make-an-item 'file-menu 'close
|
|
'(string-constant close-info)
|
|
'(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
|
|
#\w
|
|
'(string-constant close-menu-item)
|
|
on-demand-do-nothing
|
|
#t)
|
|
(make-between 'file-menu 'close 'quit 'nothing)
|
|
(make-an-item 'file-menu 'quit
|
|
'(string-constant quit-info)
|
|
'(λ (item control)
|
|
(when (exit:user-oks-exit)
|
|
(exit:exit)))
|
|
#\q
|
|
'(if (eq? (system-type) 'windows)
|
|
(string-constant quit-menu-item-windows)
|
|
(string-constant quit-menu-item-others))
|
|
on-demand-do-nothing
|
|
'(not (current-eventspace-has-standard-menus?)))
|
|
(make-after 'file-menu 'quit 'nothing)
|
|
|
|
(make-an-item 'edit-menu 'undo
|
|
'(string-constant undo-info)
|
|
(edit-menu:do 'undo)
|
|
#\z
|
|
'(string-constant undo-menu-item)
|
|
(edit-menu:can-do-on-demand 'undo)
|
|
#t)
|
|
(make-an-item 'edit-menu 'redo
|
|
'(string-constant redo-info)
|
|
(edit-menu:do 'redo)
|
|
#\y
|
|
'(string-constant redo-menu-item)
|
|
(edit-menu:can-do-on-demand 'redo)
|
|
#t)
|
|
(make-between 'edit-menu 'redo 'cut 'separator)
|
|
(make-an-item 'edit-menu 'cut '(string-constant cut-info)
|
|
(edit-menu:do 'cut)
|
|
#\x
|
|
'(string-constant cut-menu-item)
|
|
(edit-menu:can-do-on-demand 'cut)
|
|
#t)
|
|
(make-between 'edit-menu 'cut 'copy 'nothing)
|
|
(make-an-item 'edit-menu 'copy
|
|
'(string-constant copy-info)
|
|
(edit-menu:do 'copy)
|
|
#\c
|
|
'(string-constant copy-menu-item)
|
|
(edit-menu:can-do-on-demand 'copy)
|
|
#t)
|
|
(make-between 'edit-menu 'copy 'paste 'nothing)
|
|
(make-an-item 'edit-menu 'paste
|
|
'(string-constant paste-info)
|
|
(edit-menu:do 'paste)
|
|
#\v
|
|
'(string-constant paste-menu-item)
|
|
(edit-menu:can-do-on-demand 'paste)
|
|
#t)
|
|
(make-between 'edit-menu 'paste 'clear 'nothing)
|
|
(make-an-item 'edit-menu 'clear
|
|
'(string-constant clear-info)
|
|
(edit-menu:do 'clear)
|
|
#f
|
|
'(if (eq? (system-type) 'windows)
|
|
(string-constant clear-menu-item-windows)
|
|
(string-constant clear-menu-item-windows))
|
|
(edit-menu:can-do-on-demand 'clear)
|
|
#t)
|
|
(make-between 'edit-menu 'clear 'select-all 'nothing)
|
|
(make-an-item 'edit-menu 'select-all
|
|
'(string-constant select-all-info)
|
|
(edit-menu:do 'select-all)
|
|
#\a
|
|
'(string-constant select-all-menu-item)
|
|
(edit-menu:can-do-on-demand 'select-all)
|
|
#t)
|
|
(make-between 'edit-menu 'select-all 'find 'separator)
|
|
|
|
(make-an-item 'edit-menu 'find
|
|
'(string-constant find-info)
|
|
'(λ (item control) (void))
|
|
#\f
|
|
'(string-constant find-menu-item)
|
|
edit-menu:edit-target-on-demand
|
|
#f)
|
|
(make-an-item 'edit-menu 'find-again
|
|
'(string-constant find-again-info)
|
|
'(λ (item control) (void))
|
|
#\g
|
|
'(string-constant find-again-menu-item)
|
|
edit-menu:edit-target-on-demand
|
|
#f)
|
|
(make-an-item 'edit-menu 'replace-and-find-again
|
|
'(string-constant replace-and-find-again-info)
|
|
'(λ (item control) (void))
|
|
'(if (eq? (system-type) 'macosx) #f #\h)
|
|
'(string-constant replace-and-find-again-menu-item)
|
|
edit-menu:edit-target-on-demand
|
|
#f)
|
|
|
|
(make-between 'edit-menu 'find 'preferences 'nothing-with-standard-menus)
|
|
(make-an-item 'edit-menu 'preferences
|
|
'(string-constant preferences-info)
|
|
'(λ (item control) (preferences:show-dialog) #t)
|
|
#\;
|
|
'(string-constant preferences-menu-item)
|
|
on-demand-do-nothing
|
|
'(not (current-eventspace-has-standard-menus?)))
|
|
(make-after 'edit-menu 'preferences 'nothing)
|
|
|
|
(make-before 'help-menu 'about 'nothing)
|
|
(make-an-item 'help-menu 'about
|
|
'(string-constant about-info)
|
|
'(λ (item control) (void))
|
|
#f
|
|
'(string-constant about-menu-item)
|
|
on-demand-do-nothing
|
|
#f)
|
|
(make-after 'help-menu 'about 'nothing))))
|