no message
original commit: 87d4796f2770f70b1f76d18ab47d8b37a639b46b
This commit is contained in:
parent
3b9a87a864
commit
94cdbd46b2
File diff suppressed because it is too large
Load Diff
|
@ -1,13 +1,9 @@
|
|||
#!/bin/sh
|
||||
|
||||
string=? ; exec mred -qr $0
|
||||
|
||||
(require-library "pretty.ss")
|
||||
(require-library "function.ss")
|
||||
|
||||
(require-library "errortrace.ss" "errortrace")
|
||||
|
||||
(require-library "standard-menus-items.ss" "framework")
|
||||
(require (lib "pretty.ss"))
|
||||
(require (lib "list.ss"))
|
||||
(require (lib "standard-menus-items.ss" "framework" "private"))
|
||||
|
||||
(define build-id
|
||||
(case-lambda
|
||||
|
@ -83,7 +79,7 @@ string=? ; exec mred -qr $0
|
|||
(if (string=? special "")
|
||||
(string-append base suffix)
|
||||
(string-append base " " special suffix))))])
|
||||
`(private
|
||||
`(private-field
|
||||
[,(build-id item "-item")
|
||||
(and ,name
|
||||
(make-object (class (get-menu-item%) args
|
||||
|
@ -143,7 +139,7 @@ string=? ; exec mred -qr $0
|
|||
,(generic-override-initializer generic)]))
|
||||
|
||||
|
||||
(define standard-menus.ss-filename (build-path (collection-path "framework") "standard-menus.ss"))
|
||||
(define standard-menus.ss-filename (build-path (collection-path "framework" "private") "standard-menus.ss"))
|
||||
(printf "writing to ~a~n" standard-menus.ss-filename)
|
||||
|
||||
(call-with-output-file standard-menus.ss-filename
|
||||
|
@ -169,7 +165,7 @@ string=? ; exec mred -qr $0
|
|||
`(define standard-menus-mixin
|
||||
(mixin (basic<%>) (standard-menus<%>) args
|
||||
(inherit on-menu-char on-traverse-char)
|
||||
(private
|
||||
(private-field
|
||||
[remove-prefs-callback
|
||||
(preferences:add-callback
|
||||
'framework:menu-bindings
|
||||
|
|
|
@ -1,242 +1,262 @@
|
|||
(define-struct generic (name initializer documentation))
|
||||
(define-struct generic-override (name initializer documentation))
|
||||
|
||||
(define-struct before/after (menu name procedure))
|
||||
(define-struct (before struct:before/after) ())
|
||||
(define-struct (after struct:before/after) ())
|
||||
(define (before/after->name before/after)
|
||||
(string->symbol (format "~a:~a-~a"
|
||||
(before/after-menu before/after)
|
||||
(if (before? before/after)
|
||||
"before"
|
||||
"after")
|
||||
(before/after-name before/after))))
|
||||
|
||||
(define-struct between (menu before after procedure))
|
||||
(define (between->name between)
|
||||
(string->symbol (format "~a:between-~a-and-~a"
|
||||
(between-menu between)
|
||||
(between-before between)
|
||||
(between-after between))))
|
||||
|
||||
(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 "")]
|
||||
[(item middle)
|
||||
(string->symbol (format "~a:~a~a"
|
||||
(an-item-menu-name item)
|
||||
middle
|
||||
(an-item-item-name item)))]))
|
||||
|
||||
(define (edit-menu:do const)
|
||||
`(lambda (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)
|
||||
`(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-override
|
||||
'on-close '(lambda ()
|
||||
(remove-prefs-callback)
|
||||
(super-on-close))
|
||||
'("@return : void"
|
||||
"Removes the preferences callbacks for the menu items"))
|
||||
(make-generic 'get-menu% '(lambda () 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})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu"))
|
||||
(make-generic 'get-menu-item% '(lambda () menu:can-restore-menu-item%)
|
||||
'("The result of this method is used as the class for creating"
|
||||
"the menu items in this class (see "
|
||||
"@link frame:standard-menus"
|
||||
"for a list)."
|
||||
""
|
||||
"@return : (derived-from \\iscmclass{menu-item})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu:can-restore-menu-item %"
|
||||
"."))
|
||||
(make-generic 'get-checkable-menu-item% '(lambda () 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 'get-file-menu
|
||||
'(let ([m (make-object (get-menu%)
|
||||
(if (eq? (system-type) 'windows)
|
||||
"&File" "F&ile")
|
||||
(get-menu-bar))])
|
||||
(lambda () m))
|
||||
'("Returns the file menu"
|
||||
"See also"
|
||||
"@ilink frame:standard-menus get-menu\\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-edit-menu
|
||||
'(let ([m (make-object (get-menu%) "&Edit" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the edit menu"
|
||||
"See also"
|
||||
"@ilink frame:standard-menus get-menu\\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-help-menu
|
||||
'(let ([m (make-object (get-menu%) "&Help" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the help menu"
|
||||
"See also"
|
||||
"@ilink frame:standard-menus get-menu\\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
|
||||
(make-an-item 'file-menu 'new "Open a new file"
|
||||
'(lambda (item control) (handler:edit-file #f) #t)
|
||||
#\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" "..."
|
||||
'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" ""
|
||||
'void)
|
||||
(make-between 'file-menu 'revert 'save 'nothing)
|
||||
(make-an-item 'file-menu 'save
|
||||
"Save this file to disk"
|
||||
#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..."
|
||||
'void)
|
||||
(make-between 'file-menu 'save-as 'print 'separator)
|
||||
(make-an-item 'file-menu 'print
|
||||
"Print this file"
|
||||
#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" ""
|
||||
'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" ""
|
||||
(edit-menu:can-do-on-demand 'undo))
|
||||
(make-an-item 'edit-menu 'redo "Redo the most recent undo"
|
||||
(edit-menu:do '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" ""
|
||||
(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" ""
|
||||
(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" ""
|
||||
(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)
|
||||
#f
|
||||
'(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" ""
|
||||
(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" "..."
|
||||
edit-menu:edit-target-on-demand)
|
||||
(make-an-item 'edit-menu 'find-again "Search for the same string as before" #f
|
||||
#\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" ""
|
||||
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..." ""
|
||||
'void)
|
||||
(make-after 'edit-menu 'preferences 'nothing)
|
||||
|
||||
(make-before 'help-menu 'about 'nothing)
|
||||
(make-an-item 'help-menu 'about "Learn something about this application"
|
||||
#f
|
||||
#f
|
||||
"About "
|
||||
"..."
|
||||
'void)
|
||||
(make-after 'help-menu 'about 'nothing)))
|
||||
(module standard-menus-items mzscheme
|
||||
(provide
|
||||
(struct generic (name initializer documentation))
|
||||
(struct generic-override (name initializer documentation))
|
||||
|
||||
(struct before/after (menu name procedure))
|
||||
(struct before ())
|
||||
(struct after ())
|
||||
|
||||
(struct between (menu before after procedure))
|
||||
before/after->name
|
||||
between->name
|
||||
|
||||
an-item->name
|
||||
items
|
||||
edit-menu:do
|
||||
edit-menu:do-on-demand
|
||||
edit-menu:edit-target-on-demand
|
||||
edit-menu:edit-target-on-demand)
|
||||
|
||||
(define-struct generic (name initializer documentation))
|
||||
(define-struct generic-override (name initializer documentation))
|
||||
|
||||
(define-struct before/after (menu name procedure))
|
||||
(define-struct (before struct:before/after) ())
|
||||
(define-struct (after struct:before/after) ())
|
||||
(define (before/after->name before/after)
|
||||
(string->symbol (format "~a:~a-~a"
|
||||
(before/after-menu before/after)
|
||||
(if (before? before/after)
|
||||
"before"
|
||||
"after")
|
||||
(before/after-name before/after))))
|
||||
|
||||
(define-struct between (menu before after procedure))
|
||||
(define (between->name between)
|
||||
(string->symbol (format "~a:between-~a-and-~a"
|
||||
(between-menu between)
|
||||
(between-before between)
|
||||
(between-after between))))
|
||||
|
||||
(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 "")]
|
||||
[(item middle)
|
||||
(string->symbol (format "~a:~a~a"
|
||||
(an-item-menu-name item)
|
||||
middle
|
||||
(an-item-item-name item)))]))
|
||||
|
||||
(define (edit-menu:do const)
|
||||
`(lambda (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)
|
||||
`(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-override
|
||||
'on-close '(lambda ()
|
||||
(remove-prefs-callback)
|
||||
(super-on-close))
|
||||
'("@return : void"
|
||||
"Removes the preferences callbacks for the menu items"))
|
||||
(make-generic 'get-menu% '(lambda () 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})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu"))
|
||||
(make-generic 'get-menu-item% '(lambda () menu:can-restore-menu-item%)
|
||||
'("The result of this method is used as the class for creating"
|
||||
"the menu items in this class (see "
|
||||
"@link frame:standard-menus"
|
||||
"for a list)."
|
||||
""
|
||||
"@return : (derived-from \\iscmclass{menu-item})"
|
||||
""
|
||||
"defaultly returns"
|
||||
"@link menu:can-restore-menu-item %"
|
||||
"."))
|
||||
(make-generic 'get-checkable-menu-item% '(lambda () 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 'get-file-menu
|
||||
'(let ([m (make-object (get-menu%)
|
||||
(if (eq? (system-type) 'windows)
|
||||
"&File" "F&ile")
|
||||
(get-menu-bar))])
|
||||
(lambda () m))
|
||||
'("Returns the file menu"
|
||||
"See also"
|
||||
"@ilink frame:standard-menus get-menu\\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-edit-menu
|
||||
'(let ([m (make-object (get-menu%) "&Edit" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the edit menu"
|
||||
"See also"
|
||||
"@ilink frame:standard-menus get-menu\\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
(make-generic 'get-help-menu
|
||||
'(let ([m (make-object (get-menu%) "&Help" (get-menu-bar))])
|
||||
(lambda () m))
|
||||
|
||||
'("Returns the help menu"
|
||||
"See also"
|
||||
"@ilink frame:standard-menus get-menu\\%"
|
||||
""
|
||||
"@return : (instance (derived-from \\iscmclass{menu}))"))
|
||||
|
||||
(make-an-item 'file-menu 'new "Open a new file"
|
||||
'(lambda (item control) (handler:edit-file #f) #t)
|
||||
#\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" "..."
|
||||
'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" ""
|
||||
'void)
|
||||
(make-between 'file-menu 'revert 'save 'nothing)
|
||||
(make-an-item 'file-menu 'save
|
||||
"Save this file to disk"
|
||||
#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..."
|
||||
'void)
|
||||
(make-between 'file-menu 'save-as 'print 'separator)
|
||||
(make-an-item 'file-menu 'print
|
||||
"Print this file"
|
||||
#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" ""
|
||||
'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" ""
|
||||
(edit-menu:can-do-on-demand 'undo))
|
||||
(make-an-item 'edit-menu 'redo "Redo the most recent undo"
|
||||
(edit-menu:do '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" ""
|
||||
(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" ""
|
||||
(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" ""
|
||||
(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)
|
||||
#f
|
||||
'(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" ""
|
||||
(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" "..."
|
||||
edit-menu:edit-target-on-demand)
|
||||
(make-an-item 'edit-menu 'find-again "Search for the same string as before" #f
|
||||
#\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" ""
|
||||
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..." ""
|
||||
'void)
|
||||
(make-after 'edit-menu 'preferences 'nothing)
|
||||
|
||||
(make-before 'help-menu 'about 'nothing)
|
||||
(make-an-item 'help-menu 'about "Learn something about this application"
|
||||
#f
|
||||
#f
|
||||
"About "
|
||||
"..."
|
||||
'void)
|
||||
(make-after 'help-menu 'about 'nothing))))
|
Loading…
Reference in New Issue
Block a user