From c68eb72239dc0e81f47a9d70be55c436b6f8ee08 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 11 Sep 2000 16:01:01 +0000
Subject: [PATCH] .

original commit: 5776f3f92796d8cdd88e4f0c9ba4cd45d7effffa
---
 collects/framework/frame.ss                |  1 +
 collects/framework/frameworks.ss           |  8 +++
 collects/framework/gen-standard-menus.ss   | 62 +++++++++++-----------
 collects/framework/standard-menus-items.ss | 10 ++--
 4 files changed, 47 insertions(+), 34 deletions(-)

diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss
index 96002edd..bd4cf685 100644
--- a/collects/framework/frame.ss
+++ b/collects/framework/frame.ss
@@ -15,6 +15,7 @@
 	  [pasteboard : framework:pasteboard^]
 	  [editor : framework:editor^]
 	  [canvas : framework:canvas^]
+          [menu : framework:menu^]
 	  [mzlib:function : mzlib:function^]
 	  [mzlib:file : mzlib:file^])
 
diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss
index 1c1ec32e..3ba5365a 100644
--- a/collects/framework/frameworks.ss
+++ b/collects/framework/frameworks.ss
@@ -11,6 +11,12 @@
 (require-relative-library "tests.ss")
 (require-relative-library "guiutilss.ss")
 
+(define-signature framework:menu^
+  (can-restore<%>
+   can-restore-mixin
+   can-restore-menu-item%
+   can-restore-checkable-menu-item%))
+
 (define-signature framework:prefs-file^
   (get-preferences-filename))
 
@@ -301,6 +307,8 @@
 
    [unit panel : framework:panel^]
 
+   [unit menu : framework:menu^]
+   
    [unit frame : framework:frame^]
    [unit scheme : framework:scheme^]
    [unit main : framework:main^]))
diff --git a/collects/framework/gen-standard-menus.ss b/collects/framework/gen-standard-menus.ss
index 166e00b9..4209ba93 100755
--- a/collects/framework/gen-standard-menus.ss
+++ b/collects/framework/gen-standard-menus.ss
@@ -99,7 +99,7 @@ string=? ; exec mred -qr $0
 	       ,(menu-name->id name-string)
                (let ([,name (lambda (item evt) (,name item evt))])
                  ,name)
-	       (if (preferences:get 'framework:menu-bindings) ,key #f)
+	       ,key
 	       (,(build-id item "-help-string"))))])))
 
 (define build-menu-clause
@@ -155,36 +155,38 @@ string=? ; exec mred -qr $0
      `(define standard-menus-mixin
 	(mixin (basic<%>) (standard-menus<%>) args
           (inherit on-menu-char on-traverse-char)
-	  (rename [super-on-subwindow-char on-subwindow-char])
-          (override
-            [on-subwindow-char
-             (lambda (receiver event)
-               (if (preferences:get 'framework:menu-bindings)
-		   (super-on-subwindow-char receiver event)
-                   (on-traverse-char event)))])
+;	  (rename [super-on-subwindow-char on-subwindow-char])
+;          (override
+;            [on-subwindow-char
+;             (lambda (receiver event)
+;               (if (preferences:get 'framework:menu-bindings)
+;		   (super-on-subwindow-char receiver event)
+;                   (on-traverse-char event)))])
           
-;         need to save old keybindings...
-;	  (rename [super-on-close on-close])
-;	  (private
-;	    [remove-prefs-callback
-;	     (preferences:add-callback
-;	      'framework:menu-bindings
-;	      (lambda (p v)
-;		(let ([mb (get-menu-bar)])
-;		  (let loop ([menu (get-menu-bar)])
-;		    (cond
-;		     [(is-a? menu menu-item-container<%>)
-;		      (for-each loop (send menu get-items))]
-;		     [(is-a? menu selectable-menu-item<%>)
-;		      (void)])))))])
-
-;	  (override
-;	   [on-close
-;	    (lambda ()
-;	      (remove-prefs-callback)
-;	      (super-on-close))])
-
-	  (inherit get-menu-bar can-close? on-close show get-edit-target-object)
+	  (rename [super-on-close on-close])
+	  (private
+	    [remove-prefs-callback
+	     (preferences:add-callback
+	      'framework:menu-bindings
+	      (lambda (p v)
+		(let ([mb (get-menu-bar)])
+		  (let loop ([menu (get-menu-bar)])
+		    (cond
+                      [(is-a? menu menu-item-container<%>)
+                       (for-each loop (send menu get-items))]
+                      [(is-a? menu selectable-menu-item<%>)
+                       (when (is-a? menu menu:can-restore<%>)
+                         (if v
+                             (send menu restore-keybinding)
+                             (send menu set-shortcut #f)))])))))])
+          
+	  (override
+            [on-close
+             (lambda ()
+               (remove-prefs-callback)
+               (super-on-close))])
+          
+	  (inherit get-menu-bar show can-close? get-edit-target-object)
 	  (sequence (apply super-init args))
 	  ,@(append 
 	     (map (lambda (x)
diff --git a/collects/framework/standard-menus-items.ss b/collects/framework/standard-menus-items.ss
index 961c8842..0f35ea4e 100644
--- a/collects/framework/standard-menus-items.ss
+++ b/collects/framework/standard-menus-items.ss
@@ -72,7 +72,7 @@
 			""
 			"defaultly returns"
 			"@link menu"))
-	(make-generic 'get-menu-item% '(lambda () menu-item%)
+	(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"
@@ -81,8 +81,9 @@
 			"@return : (derived-from \\iscmclass{menu-item})"
 			""
 			"defaultly returns"
-			"@link menu-item"))
-	(make-generic 'get-checkable-menu-item% '(lambda () checkable-menu-item%)
+			"@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"
@@ -91,7 +92,8 @@
 			"@return : (derived-from \\iscmclass{checkable-menu-item})"
 			""
 			"defaultly returns"
-			"@link menu-item"))
+			"@link menu:can-restore-checkable-menu-item %"
+                        "."))
 
 	(make-generic 'get-file-menu
 		      '(let ([m (make-object (get-menu%)