From c948e8cbc6f9437bbcf824766658497b1fdf5c11 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Jun 2006 19:44:18 +0000 Subject: [PATCH] used capability interface for a bunch more special menu items svn: r3205 --- collects/drscheme/private/main.ss | 5 +- collects/drscheme/private/tool-contracts.ss | 19 ++++- collects/drscheme/private/unit.ss | 34 ++++++-- collects/framework/framework.ss | 10 ++- collects/framework/private/frame.ss | 90 +++++++++++---------- collects/guibuilder/tool.ss | 9 ++- collects/profj/tool.ss | 4 +- collects/slideshow/tool.ss | 7 +- collects/stepper/xml-tool.ss | 12 ++- collects/xml/text-box-tool.ss | 12 ++- 10 files changed, 132 insertions(+), 70 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index b466c60744..62a0611d83 100644 --- a/collects/drscheme/private/main.ss +++ b/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) diff --git a/collects/drscheme/private/tool-contracts.ss b/collects/drscheme/private/tool-contracts.ss index 587dc8f1a6..3662b4eb6a 100644 --- a/collects/drscheme/private/tool-contracts.ss +++ b/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?) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 40c3600758..796e8e2bde 100644 --- a/collects/drscheme/private/unit.ss +++ b/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 diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 41da6c4387..e3b48f2b9a 100644 --- a/collects/framework/framework.ss +++ b/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?) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index d89e0dbeee..428af5cfce 100644 --- a/collects/framework/private/frame.ss +++ b/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) diff --git a/collects/guibuilder/tool.ss b/collects/guibuilder/tool.ss index 82330fdaf4..b904419038 100644 --- a/collects/guibuilder/tool.ss +++ b/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)))) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index b6738dfac4..39225f431f 100644 --- a/collects/profj/tool.ss +++ b/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) diff --git a/collects/slideshow/tool.ss b/collects/slideshow/tool.ss index 5018656441..22edaf6897 100644 --- a/collects/slideshow/tool.ss +++ b/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 diff --git a/collects/stepper/xml-tool.ss b/collects/stepper/xml-tool.ss index 0f89565f8e..e5d18d30c2 100644 --- a/collects/stepper/xml-tool.ss +++ b/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)))) diff --git a/collects/xml/text-box-tool.ss b/collects/xml/text-box-tool.ss index bcfb880175..d3180430dd 100644 --- a/collects/xml/text-box-tool.ss +++ b/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))))