...
original commit: dfa6397102223b335100ced0b5615f7b03a2b5ef
This commit is contained in:
Robby Findler
parent
9d395fc085
commit
3896ab90c9
|
|
@ -36,7 +36,8 @@ string=? ; exec mred -qr $0
|
|||
(list (an-item->name item)
|
||||
(build-id item "-item" "get-")
|
||||
(build-id item "-string")
|
||||
(build-id item "-help-string")))
|
||||
(build-id item "-help-string")
|
||||
(build-id item "-on-demand")))
|
||||
|
||||
(define build-fill-in-item-clause
|
||||
(lambda (item)
|
||||
|
|
@ -48,7 +49,8 @@ string=? ; exec mred -qr $0
|
|||
(list proc
|
||||
`(lambda () ,(build-id item "-item"))
|
||||
`(lambda () "")
|
||||
`(lambda () ,help-string)))))))
|
||||
`(lambda () ,help-string)
|
||||
(an-item-on-demand item)))))))
|
||||
|
||||
(define build-fill-in-clause
|
||||
(lambda (->name -procedure)
|
||||
|
|
@ -74,17 +76,26 @@ string=? ; exec mred -qr $0
|
|||
[menu-before-string (an-item-menu-string-before item)]
|
||||
[menu-after-string (an-item-menu-string-after item)]
|
||||
[key (an-item-key item)]
|
||||
[join '(lambda (base special suffix)
|
||||
(if (string=? special "")
|
||||
(string-append base suffix)
|
||||
(string-append base " " special suffix)))])
|
||||
[join (lambda (base-text suffix-text special-text)
|
||||
`(let ([special ,special-text]
|
||||
[base ,base-text]
|
||||
[suffix ,suffix-text])
|
||||
(if (string=? special "")
|
||||
(string-append base suffix)
|
||||
(string-append base " " special suffix))))])
|
||||
`(private
|
||||
[,(build-id item "-item")
|
||||
(and ,name
|
||||
(make-object (get-menu-item%)
|
||||
(,join ,menu-before-string
|
||||
(,(build-id item "-string"))
|
||||
,menu-after-string)
|
||||
(make-object (class (get-menu-item%) args
|
||||
(rename [super-on-demand on-demand])
|
||||
(override
|
||||
[on-demand
|
||||
(lambda ()
|
||||
(,(build-id item "-on-demand") this)
|
||||
(super-on-demand))])
|
||||
(sequence (apply super-init args)))
|
||||
,(join menu-before-string menu-after-string
|
||||
`(,(build-id item "-string")))
|
||||
,(menu-name->id name-string)
|
||||
,name
|
||||
(if (preferences:get 'framework:menu-bindings) ,key #f)
|
||||
|
|
|
|||
|
|
@ -18,7 +18,14 @@
|
|||
(between-before between)
|
||||
(between-after between))))
|
||||
|
||||
(define-struct an-item (menu-name item-name help-string proc key menu-string-before menu-string-after))
|
||||
(define-struct an-item (menu-name
|
||||
item-name
|
||||
help-string
|
||||
proc
|
||||
key
|
||||
menu-string-before
|
||||
menu-string-after
|
||||
on-demand))
|
||||
(define an-item->name
|
||||
(case-lambda
|
||||
[(item) (an-item->name item "")]
|
||||
|
|
@ -36,6 +43,21 @@
|
|||
(send edit do-edit-operation ',const)))
|
||||
#t))
|
||||
|
||||
(define (edit-menu:can-do-on-demand const)
|
||||
`(lambda (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
|
||||
`(lambda (item)
|
||||
(send item enable
|
||||
(let ([target (get-edit-target-object)])
|
||||
(and target (is-a? target editor<%>))))))
|
||||
|
||||
(define items
|
||||
(list (make-generic 'get-menu% '(lambda () menu%)
|
||||
'("The result of this method is used as the class for creating the result of these methods:"
|
||||
|
|
@ -103,58 +125,71 @@
|
|||
|
||||
(make-an-item 'file-menu 'new "Open a new file"
|
||||
'(lambda (item control) (handler:edit-file #f) #t)
|
||||
#\n "&New" "")
|
||||
#\n "&New" ""
|
||||
'void)
|
||||
(make-between 'file-menu 'new 'open 'nothing)
|
||||
(make-an-item 'file-menu 'open "Open a file from disk"
|
||||
'(lambda (item control) (handler:open-file) #t)
|
||||
#\o "&Open" "...")
|
||||
#\o "&Open" "..."
|
||||
'void)
|
||||
(make-between 'file-menu 'open 'revert 'nothing)
|
||||
(make-an-item 'file-menu 'revert
|
||||
"Revert this file to the copy on disk"
|
||||
#f #f "&Revert" "")
|
||||
#f #f "&Revert" ""
|
||||
'void)
|
||||
(make-between 'file-menu 'revert 'save 'nothing)
|
||||
(make-an-item 'file-menu 'save
|
||||
"Save this file to disk"
|
||||
#f #\s "&Save" "")
|
||||
#f #\s "&Save" ""
|
||||
'void)
|
||||
(make-an-item 'file-menu 'save-as
|
||||
"Prompt for a filename and save this file to disk"
|
||||
#f #f "Save" " &As...")
|
||||
#f #f "Save" " &As..."
|
||||
'void)
|
||||
(make-between 'file-menu 'save-as 'print 'separator)
|
||||
(make-an-item 'file-menu 'print
|
||||
"Print this file"
|
||||
#f #\p "&Print" "...")
|
||||
#f #\p "&Print" "..."
|
||||
'void)
|
||||
(make-between 'file-menu 'print 'close 'separator)
|
||||
(make-an-item 'file-menu 'close
|
||||
"Close this file"
|
||||
'(lambda (item control) (when (can-close?) (on-close) (show #f)) #t)
|
||||
#\w "&Close" "")
|
||||
#\w "&Close" ""
|
||||
'void)
|
||||
(make-between 'file-menu 'close 'quit 'nothing)
|
||||
(make-an-item 'file-menu 'quit
|
||||
"Quit"
|
||||
'(lambda (item control) (parameterize ([exit:frame-exiting this]) (exit:exit)))
|
||||
#\q
|
||||
'(if (eq? (system-type) 'windows) "E&xit" "Quit")
|
||||
"")
|
||||
""
|
||||
'void)
|
||||
(make-after 'file-menu 'quit 'nothing)
|
||||
|
||||
(make-an-item 'edit-menu 'undo "Undo the most recent action"
|
||||
(edit-menu:do 'undo)
|
||||
#\z "&Undo" "")
|
||||
#\z "&Undo" ""
|
||||
(edit-menu:can-do-on-demand 'undo))
|
||||
(make-an-item 'edit-menu 'redo "Redo the most recent undo"
|
||||
(edit-menu:do 'redo)
|
||||
#\y "&Redo" "")
|
||||
#\y "&Redo" ""
|
||||
(edit-menu:can-do-on-demand 'redo))
|
||||
(make-between 'edit-menu 'redo 'cut 'separator)
|
||||
(make-an-item 'edit-menu 'cut "Cut the selection"
|
||||
(edit-menu:do 'cut)
|
||||
#\x "Cu&t" "")
|
||||
#\x "Cu&t" ""
|
||||
(edit-menu:can-do-on-demand 'cut))
|
||||
(make-between 'edit-menu 'cut 'copy 'nothing)
|
||||
(make-an-item 'edit-menu 'copy "Copy the selection"
|
||||
(edit-menu:do 'copy)
|
||||
#\c "&Copy" "")
|
||||
#\c "&Copy" ""
|
||||
(edit-menu:can-do-on-demand 'copy))
|
||||
(make-between 'edit-menu 'copy 'paste 'nothing)
|
||||
(make-an-item 'edit-menu 'paste "Paste the most recent copy or cut over the selection"
|
||||
(edit-menu:do 'paste)
|
||||
#\v "&Paste" "")
|
||||
#\v "&Paste" ""
|
||||
(edit-menu:can-do-on-demand 'paste))
|
||||
(make-between 'edit-menu 'paste 'clear 'nothing)
|
||||
(make-an-item 'edit-menu 'clear "Clear the selection without affecting paste"
|
||||
(edit-menu:do 'clear)
|
||||
|
|
@ -162,23 +197,29 @@
|
|||
'(if (eq? (system-type) 'macos)
|
||||
"Clear"
|
||||
"&Delete")
|
||||
"")
|
||||
""
|
||||
(edit-menu:can-do-on-demand 'clear))
|
||||
(make-between 'edit-menu 'clear 'select-all 'nothing)
|
||||
(make-an-item 'edit-menu 'select-all "Select the entire document"
|
||||
(edit-menu:do 'select-all)
|
||||
#\a "Select A&ll" "")
|
||||
#\a "Select A&ll" ""
|
||||
(edit-menu:can-do-on-demand 'select-all))
|
||||
(make-between 'edit-menu 'select-all 'find 'separator)
|
||||
(make-an-item 'edit-menu 'find "Search for a string in the window" #f
|
||||
#\f "Find" "...")
|
||||
#\f "Find" "..."
|
||||
edit-menu:edit-target-on-demand)
|
||||
(make-an-item 'edit-menu 'find-again "Search for the same string as before" #f
|
||||
#\g "Find Again" "")
|
||||
#\g "Find Again" ""
|
||||
edit-menu:edit-target-on-demand)
|
||||
(make-an-item 'edit-menu 'replace-and-find-again
|
||||
"Replace the current text and search for the same string as before"
|
||||
#f #\h "Replace && Find Again" "")
|
||||
#f #\h "Replace && Find Again" ""
|
||||
edit-menu:edit-target-on-demand)
|
||||
(make-between 'edit-menu 'find 'preferences 'separator)
|
||||
(make-an-item 'edit-menu 'preferences "Configure the preferences"
|
||||
'(lambda (item control) (preferences:show-dialog) #t)
|
||||
#f "Preferences..." "")
|
||||
#f "Preferences..." ""
|
||||
'void)
|
||||
(make-after 'edit-menu 'preferences 'nothing)
|
||||
|
||||
(make-before 'help-menu 'about 'nothing)
|
||||
|
|
@ -186,5 +227,6 @@
|
|||
#f
|
||||
#f
|
||||
"About "
|
||||
"...")
|
||||
"..."
|
||||
'void)
|
||||
(make-after 'help-menu 'about 'nothing)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user