From 3896ab90c96104cc47719c44cbf146f1c83cc12a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 11 Jun 2000 13:39:50 +0000 Subject: [PATCH] ... original commit: dfa6397102223b335100ced0b5615f7b03a2b5ef --- collects/framework/gen-standard-menus.ss | 31 +++++--- collects/framework/standard-menus-items.ss | 84 ++++++++++++++++------ 2 files changed, 84 insertions(+), 31 deletions(-) diff --git a/collects/framework/gen-standard-menus.ss b/collects/framework/gen-standard-menus.ss index 132fd50d..783ef21f 100755 --- a/collects/framework/gen-standard-menus.ss +++ b/collects/framework/gen-standard-menus.ss @@ -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) diff --git a/collects/framework/standard-menus-items.ss b/collects/framework/standard-menus-items.ss index 70113c8c..961c8842 100644 --- a/collects/framework/standard-menus-items.ss +++ b/collects/framework/standard-menus-items.ss @@ -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)))