used capability interface for a bunch more special menu items

svn: r3205

collects/drscheme/private/main.ss

@@ -251,11 +251,12 @@
       (drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)
       (drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)
       (drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)
+      (drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)
+      (drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)
       (drscheme:language:register-capability 'drscheme:language-menu-title 
                                              (flat-contract string?)
                                              (string-constant scheme-menu-name))
-      
-      
+           
       (handler:current-create-new-window
        (let ([drscheme-current-create-new-window
 	      (λ (filename)

collects/drscheme/private/tool-contracts.ss

@@ -900,10 +900,10 @@
   
   (drscheme:language:register-capability
    (->r ([s symbol?]
-         [contract contract?]
-         [default contract])
+         [the-contract contract?]
+         [default the-contract])
         void?)
-   (s contract default)
+   (s the-contract default)
    "Registers a new capability with a default value for each language"
    "and a contract on the values the capability might have."
    ""
@@ -920,6 +920,19 @@
    " --- determines if the insert lambda menu item in the special menu is visible"
    "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)|"
    " --- determines if the insert large letters menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)|"
+   " --- determines if the insert image menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)|"
+   " --- determines if the insert comment box menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t)|"
+   " --- determines if the insert gui menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:slideshow-menu-item (flat-contract boolean?) #t)|"
+   " --- determines if the insert pict box menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-text-box (flat-contract boolean?) #t)|"
+   " --- determines if the insert text box menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t)|"
+   " --- determines if the insert scheme box, insert scheme splice box, and the insert xml box menu item ins the special menu are visible"
+   
    "\\end{itemize}")
   (drscheme:language:capability-registered? 
    (-> symbol? boolean?)

collects/drscheme/private/unit.ss

@@ -2557,7 +2557,7 @@ module browser threading seems wrong.
               (when (null? items)
                 (error 'register-capability-menu-item "menu ~e has no items" menu))
               (let* ([menu-item (car (last-pair items))]
-                     [this-one (list menu-item (length items) key)]
+                     [this-one (list menu-item (- (length items) 1) key)]
                      [old-ones (hash-table-get capability-menu-items menu (λ () '()))])
                 (hash-table-put! capability-menu-items menu (cons this-one old-ones)))))
           
@@ -2583,13 +2583,21 @@ module browser threading seems wrong.
                       (let ([is-on? (get-current-capability-value cap-key)])
                         (cond
                           [is-on?
-                           (if (eq? (car all-items) cap-item)
-                               (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))
-                               (cons cap-item (loop (cdr capability-items) all-items (+ i 1))))]
+                           (cond
+                             [(null? all-items)
+                              (cons cap-item (loop (cdr capability-items) null (+ i 1)))]
+                             [(eq? (car all-items) cap-item)
+                              (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))]
+                             [else
+                              (cons cap-item (loop (cdr capability-items) all-items (+ i 1)))])]
                           [else
-                           (if (eq? (car all-items) cap-item)
-                               (loop (cdr capability-items) (cdr all-items) (+ i 1))
-                               (loop (cdr capability-items) all-items (+ i 1)))]))]
+                           (cond
+                             [(null? all-items)
+                              (loop (cdr capability-items) null (+ i 1))]
+                             [(eq? (car all-items) cap-item)
+                              (loop (cdr capability-items) (cdr all-items) (+ i 1))]
+                             [else
+                              (loop (cdr capability-items) all-items (+ i 1))])]))]
                      [else (cons (car all-items)
                                  (loop capability-items
                                        (cdr all-items)
@@ -2879,8 +2887,18 @@ module browser threading seems wrong.
                                        (loop (- y 1)))))
                                  (send edit end-edit-sequence)))))))]
                     [c% (get-menu-item%)])
-                (frame:add-snip-menu-items special-menu c%)
                 
+                (frame:add-snip-menu-items 
+                 special-menu 
+                 c%
+                 (λ (item)
+                   (let ([label (send item get-label)])
+                     (cond
+                       [(equal? label (string-constant insert-comment-box-menu-item-label))
+                        (register-capability-menu-item 'drscheme:special:insert-comment-box special-menu)]
+                       [(equal? label (string-constant insert-image-item))
+                        (register-capability-menu-item 'drscheme:special:insert-image special-menu)]))))
+                                           
                 (make-object c% (string-constant insert-fraction-menu-item-label)
                   special-menu callback 
                   #f #f

collects/framework/framework.ss

@@ -666,14 +666,18 @@
     "The first argument should be the preferences symbol, and the second an third"
     "should be the default width and height, respectively.")
    (frame:add-snip-menu-items
-    ((is-a?/c menu%) (subclass?/c menu-item%) . -> . void?)
-    (menu menu-item%)
+    (opt-> ((is-a?/c menu%) (subclass?/c menu-item%))
+           ((-> (is-a?/c menu-item%) void?))
+           void?)
+    (menu menu-item% func)
     "Inserts three menu items into \\var{menu},"
     "one that inserts a text box, one that inserts a"
     "pasteboard box, and one that inserts an image"
     "into the currently focused editor (if there is one)."
     "Uses \\var{menu-item\\%} as the class for"
-    "the menu items.")
+    "the menu items."
+    ""
+    "Calls \\var{func} right after inserting each menu item.")
    
    (frame:reorder-menus
     ((is-a?/c frame%) . -> . void?)

collects/framework/private/frame.ss

@@ -62,48 +62,56 @@
                     (when (pair? (send menu get-items)) (send menu restore)))
                   menus))
 
-      (define (add-snip-menu-items edit-menu c%)
-        (let* ([get-edit-target-object
-                (λ ()
-                  (let ([menu-bar
-                         (let loop ([p (send edit-menu get-parent)])
-                           (cond
-                             [(is-a? p menu-bar%)
-                              p]
-                             [(is-a? p menu%)
-                              (loop (send p get-parent))]
-                             [else #f]))])
-                    (and menu-bar
-                         (let ([frame (send menu-bar get-frame)])
-                           (send frame get-edit-target-object)))))]
-               [edit-menu:do 
-                (λ (const)
-                  (λ (menu evt)
+      (define add-snip-menu-items
+        (opt-lambda (edit-menu c% [func void])
+          (let* ([get-edit-target-object
+                  (λ ()
+                    (let ([menu-bar
+                           (let loop ([p (send edit-menu get-parent)])
+                             (cond
+                               [(is-a? p menu-bar%)
+                                p]
+                               [(is-a? p menu%)
+                                (loop (send p get-parent))]
+                               [else #f]))])
+                      (and menu-bar
+                           (let ([frame (send menu-bar get-frame)])
+                             (send frame get-edit-target-object)))))]
+                 [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))]
+                 [on-demand
+                  (λ (menu-item)
                     (let ([edit (get-edit-target-object)])
-                      (when (and edit
-                                 (is-a? edit editor<%>))
-                        (send edit do-edit-operation const)))
-                    #t))]
-               [on-demand
-                (λ (menu-item)
-                  (let ([edit (get-edit-target-object)])
-                    (send menu-item enable (and edit (is-a? edit editor<%>)))))]
-               [insert-comment-box
-                 (λ ()
-                   (let ([text (get-edit-target-object)])
-                     (when text
-                       (let ([snip (make-object comment-box:snip%)])
-                         (send text insert snip)
-                         (send text set-caret-owner snip 'global)))))])
-          
-          (make-object c% (string-constant insert-comment-box-menu-item-label)
-            edit-menu 
-            (λ (x y) (insert-comment-box))
-            #f #f
-            on-demand)
-          (make-object c% (string-constant insert-image-item)
-            edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
-          (void)))
+                      (send menu-item enable (and edit (is-a? edit editor<%>)))))]
+                 [insert-comment-box
+                  (λ ()
+                    (let ([text (get-edit-target-object)])
+                      (when text
+                        (let ([snip (make-object comment-box:snip%)])
+                          (send text insert snip)
+                          (send text set-caret-owner snip 'global)))))])
+            
+            (let ([item
+                   (new c%
+                        [label (string-constant insert-comment-box-menu-item-label)]
+                        [parent edit-menu]
+                        [callback (λ (x y) (insert-comment-box))]
+                        [demand-callback on-demand])])
+              (func item))
+            (let ([item 
+                   (new c% 
+                        [label (string-constant insert-image-item)]
+                        [parent edit-menu]
+                        [callback (edit-menu:do 'insert-image)]
+                        [demand-callback on-demand])])
+              (func item))
+            (void))))
       
       (define frame-width 600)
       (define frame-height 650)

collects/guibuilder/tool.ss

@@ -5,7 +5,8 @@
            (lib "unitsig.ss")
            (lib "class.ss")
 	   (lib "string-constant.ss" "string-constants")
-	   "top-level.ss"
+	   (lib "contract.ss")
+           "top-level.ss"
 	   "toolbar.ss"
 	   "readable.ss")
 
@@ -66,4 +67,8 @@
 				       [s (make-object gui-code-snip% gb)])
 				  (send e insert s)
 				  (send gb create-main-panel)
-				  (send gb set-caret-owner #f 'display)))))))))))))
+				  (send gb set-caret-owner #f 'display))))))
+             (inherit register-capability-menu-item)
+             (register-capability-menu-item 'drscheme:special:insert-gui-tool (get-special-menu))))))
+      
+      (drscheme:language:register-capability 'drscheme:special:insert-gui-tool (flat-contract boolean?) #t))))

collects/profj/tool.ss

@@ -157,13 +157,13 @@
                          profj:special:java-examples-box 
                          profjWizard:special:java-class
                          profjWizard:special:java-union
+                         drscheme:special:insert-image
                          drscheme:special:insert-large-letters)) #t]
               [(memq s '(slideshow:special-menu 
                          drscheme:define-popup
                          profj:special:java-interactions-box)) #f]
               [(regexp-match #rx"^drscheme:special:" (format "~a" s)) #f]
-              [else
-               (drscheme:language:get-capability-default s)]))
+              [else (drscheme:language:get-capability-default s)]))
           (define/public (first-opened) (void))
           
           (define/public (order-manuals x)

collects/slideshow/tool.ss

@@ -26,6 +26,7 @@ pict snip :
            (lib "mred.ss" "mred")
            (lib "class.ss")
            (lib "unitsig.ss")
+           (lib "contract.ss")
            (lib "string-constant.ss" "string-constants")
            (lib "framework.ss" "framework")
            (lib "mrpict.ss" "texpict")
@@ -621,9 +622,9 @@ pict snip :
           
           (super-new)
           
-          (inherit get-special-menu #;register-capability-menu-item)
+          (inherit get-special-menu register-capability-menu-item)
           (add-special-menu-item (get-special-menu) this)
-          #;(register-capability-menu-item 'slideshow:special-menu (get-special-menu))))
+          (register-capability-menu-item 'drscheme:special:slideshow-menu-item (get-special-menu))))
       
       (define slideshow-dragable%
         (class panel:horizontal-dragable%
@@ -645,6 +646,8 @@ pict snip :
       ;; size of the drscheme window.
       (preferences:set-default 'plt:slideshow:panel-percentage 3/4 (lambda (x) (and (number? x) (<= 0 x 1))))
 
+      (drscheme:language:register-capability 'drscheme:special:slideshow-menu-item (flat-contract boolean?) #t)
+      
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       ;;
       ;;  communication from user thread to drscheme's repl

collects/stepper/xml-tool.ss

@@ -2,6 +2,7 @@
 (module xml-tool mzscheme
   (require "private/xml-snip-helpers.ss"
            (lib "unitsig.ss")
+           (lib "contract.ss")
            (lib "class.ss")
            (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
@@ -360,9 +361,9 @@
       
       (define (xml-box-frame-extension super%)
         (class super%
-          (inherit get-editor get-special-menu get-edit-target-object)
+          (inherit get-editor register-capability-menu-item get-special-menu get-edit-target-object)
           
-          (super-instantiate ())
+          (super-new)
           
           (let* ([menu (get-special-menu)]
                  [find-insertion-point ;; -> (union #f editor<%>)
@@ -399,6 +400,7 @@
                     (instantiate xml-snip% ()
                       [eliminate-whitespace-in-empty-tags?
                        (preferences:get 'drscheme:xml-eliminate-whitespace)]))))))
+            (register-capability-menu-item 'drscheme:special:xml-menus (get-special-menu))
             (instantiate menu:can-restore-menu-item% ()
               (label (string-constant xml-tool-insert-scheme-box))
               (parent menu)
@@ -407,6 +409,7 @@
                (lambda (menu evt)
                  (insert-snip 
                   (lambda () (instantiate scheme-snip% () (splice? #f)))))))
+            (register-capability-menu-item 'drscheme:special:xml-menus (get-special-menu))
             (instantiate menu:can-restore-menu-item% ()
               (label (string-constant xml-tool-insert-scheme-splice-box))
               (parent menu)
@@ -414,8 +417,11 @@
               (callback
                (lambda (menu evt)
                  (insert-snip
-                  (lambda () (instantiate scheme-snip% () (splice? #t))))))))
+                  (lambda () (instantiate scheme-snip% () (splice? #t)))))))
+            (register-capability-menu-item 'drscheme:special:xml-menus (get-special-menu)))
           
           (frame:reorder-menus this)))
       
+      (drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t)
+      
       (drscheme:get/extend:extend-unit-frame xml-box-frame-extension))))

collects/xml/text-box-tool.ss

@@ -4,7 +4,8 @@
            (lib "framework.ss" "framework")
            (lib "unitsig.ss")
            (lib "class.ss")
-	   (lib "string-constant.ss" "string-constants")
+	   (lib "contract.ss")
+           (lib "string-constant.ss" "string-constants")
            (lib "include-bitmap.ss" "mrlib"))
   
   (provide tool@)
@@ -140,7 +141,7 @@
             
       (define (text-box-mixin %)
         (class %
-          (inherit get-special-menu get-edit-target-object)
+          (inherit get-special-menu get-edit-target-object register-capability-menu-item)
           (super-new)
           (new menu-item%
                (label (string-constant insert-text-box-item))
@@ -150,6 +151,9 @@
                   (let ([c-box (new text-box%)]
                         [text (get-edit-target-object)])
                     (send text insert c-box)
-                    (send text set-caret-owner c-box 'global)))))))
+                    (send text set-caret-owner c-box 'global)))))
+          (register-capability-menu-item 'drscheme:special:slideshow-menu-item (get-special-menu))))
       
-      (drscheme:get/extend:extend-unit-frame text-box-mixin))))
+      (drscheme:get/extend:extend-unit-frame text-box-mixin)
+      
+      (drscheme:language:register-capability 'drscheme:special:insert-text-box (flat-contract boolean?) #t))))