suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

infrastrure for capabilities added (and added first capabilities)

Browse Source 
svn: r3119
This commit is contained in:
Robby Findler 2006-05-30 14:54:10 +00:00
parent e31dff7a58
commit b6372a2e22
12 changed files with 353 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/algol60/info.ss
View File

@ -3,3 +3,4 @@
(define doc.txt "doc.txt")
(define tools '(("tool.ss")))
(define tool-names '("Algol 60")))

1
collects/algol60/tool.ss
View File

@ -49,6 +49,7 @@
(define lang%
(class* object% (drscheme:language:language<%>)
(define/public (capability-value s) (drscheme:language:get-capability-default s))
(define/public (first-opened) (void))
(define/public (config-panel parent)
(case-lambda

5
collects/drscheme/private/drsig.ss
View File

@ -226,6 +226,11 @@
simple-module-based-language-config-panel
add-snip-value
register-capability
capability-registered?
get-capability-default
get-capability-contract
language<%>
module-based-language<%>

24
collects/drscheme/private/language.ss
View File

@ -53,6 +53,8 @@
render-value/format
render-value
capability-value
create-executable
get-language-position
@ -504,6 +506,9 @@
(inherit get-module get-transformer-module use-namespace-require/copy?
get-init-code use-mred-launcher get-reader)
(define/pubment (capability-value s)
(inner (get-capability-default s) capability-value))
(define/public (first-opened) (void))
(define/public (get-comment-character) (values "; " #\;))
(define/public (order-manuals x) (values x #t))
@ -1018,8 +1023,23 @@
(ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
(define capabilities '())
(define (capability-registered? x) (and (assoc x capabilities) #t))
(define (register-capability name contract default)
(when (capability-registered? name)
(error 'register-capability "already registered capability ~s" name))
(set! capabilities (cons (list name default contract) capabilities)))
(define (get-capability-default name)
(let ([l (assoc name capabilities)])
(unless l
(error 'get-capability-default "name not bound ~s" name))
(cadr l)))
(define (get-capability-contract name)
(let ([l (assoc name capabilities)])
(unless l
(error 'get-capability-contract "name not bound ~s" name))
(caddr l)))
;
;
;

5
collects/drscheme/private/main.ss
View File

@ -3,6 +3,7 @@
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "cmdline.ss")
(lib "contract.ss")
"drsig.ss"
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
@ -242,6 +243,10 @@
warnings-panel))))
(drscheme:debug:add-prefs-panel)
(install-help-browser-preference-panel)
(drscheme:language:register-capability 'drscheme:define-popup
(or/c (cons/c string? string?) false/c)
(cons "(define" "(define ...)"))
(handler:current-create-new-window
(let ([drscheme-current-create-new-window

28
collects/drscheme/private/rep.ss
View File

@ -943,17 +943,17 @@ TODO
;; continue to evaluate from the correct port.
(define get-sexp/syntax/eof #f)
(define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler=
(send context disable-evaluation)
(send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian))
(reset-pretty-print-width)
(when should-collect-garbage?
(set! should-collect-garbage? #f)
(collect-garbage))
(set! in-evaluation? #t)
(update-running #t)
(set! need-interaction-cleanup? #t)
(send context disable-evaluation)
(send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian))
(reset-pretty-print-width)
(when should-collect-garbage?
(set! should-collect-garbage? #f)
(collect-garbage))
(set! in-evaluation? #t)
(update-running #t)
(set! need-interaction-cleanup? #t)
(run-in-evaluation-thread
(λ () ; =User=, =Handler=, =No-Breaks=
(let* ([settings (current-language-settings)]
@ -1386,7 +1386,7 @@ TODO
click-delta)))
(unless (is-default-settings? user-language-settings)
(insert/delta this (string-append " " (string-constant custom)) dark-green-delta))
(insert/delta this (format ".~n") welcome-delta)
(insert/delta this ".\n" welcome-delta)
(for-each
(λ (fn)
@ -1394,7 +1394,7 @@ TODO
(string-append (string-constant teachpack) ": ")
welcome-delta)
(insert/delta this fn dark-green-delta)
(insert/delta this (format ".~n") welcome-delta))
(insert/delta this ".\n" welcome-delta))
(map path->string
(drscheme:teachpack:teachpack-cache-filenames
user-teachpack-cache)))
@ -1415,7 +1415,7 @@ TODO
(insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta)
(let-values ([(before after)
(insert/delta this (string-constant drscheme) click-delta drs-font-delta)])
(insert/delta this (format (string-append ", " (string-constant version) " ~a.~n") (version:version))
(insert/delta this (format (string-append ", " (string-constant version) " ~a.\n") (version:version))
welcome-delta)
(set-clickback before after
(λ args (drscheme:app:about-drscheme))

43
collects/drscheme/private/tool-contracts.ss
View File

@ -897,6 +897,42 @@
"created when drscheme is started up) is shown. If it isn't, the dialog"
"does not have the details and on the right-hand side shows the manual"
"ordering for the chosen language. This is used in Help Desk.")
(drscheme:language:register-capability
(->r ([s symbol?]
[contract contract?]
[default contract])
void?)
(s contract default)
"Registers a new capability with a default value for each language"
"and a contract on the values the capability might have."
""
"By default, these capabilities are registered as DrScheme starts up:"
"\\begin{itemize}"
"\\item \\scheme|(drscheme:language:register-capability 'drscheme:define-popup (or/c (cons/c string? string?) false/c) (cons \"(define\" \"(define ...)\"))|"
" --- specifies the prefix that the define popup should look for and what label it should have,"
"or \\scheme|#f| if it should not appear at all."
"\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)|"
" --- determines if the insert fraction menu item in the special menu is visible"
"\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)|"
" --- 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|()|"
"\\item \\scheme|()|"
"\\end{itemize}")
(drscheme:language:capability-registered?
(-> symbol? boolean?)
(s)
"Indicates if"
"@flink drscheme:langauge:register-capability"
"has been called with \\var{s}.")
(drscheme:language:get-capability-default
(->d (and/c symbol? drscheme:language:capability-registered?)
(λ (s) (drscheme:language:get-capability-contract s)))
(s)
"Returns the default for a particular capability.")
;
;
@ -1345,6 +1381,11 @@
(or/c number? (symbols 'infinity))
. -> .
any))
(unmarshall-settings (printable/c . -> . any)))
(unmarshall-settings (printable/c . -> . any))
(capability-value
(->d (and/c symbol? drscheme:language:capability-registered?)
(λ (cap-name) (drscheme:language:get-capability-contract cap-name))))
)
#;
(is-a?/c drscheme:language:language<%>)))

307
collects/drscheme/private/unit.ss
View File

@ -11,7 +11,8 @@ module browser threading seems wrong.
|#
(module unit mzscheme
(require (lib "unitsig.ss")
(require (lib "contract.ss")
(lib "unitsig.ss")
(lib "class.ss")
(lib "file.ss")
(lib "etc.ss")
@ -602,19 +603,29 @@ module browser threading seems wrong.
(keymap:add-to-right-button-menu
(λ (menu editor event)
(when (is-a? editor text%)
(let* ([current-pos (get-pos editor event)]
[current-word (and current-pos (get-current-word editor current-pos))]
[defn (and current-word
(ormap (λ (defn) (and (string=? current-word (defn-name defn))
defn))
(get-definitions #f editor)))])
(when defn
(new separator-menu-item% (parent menu))
(new menu-item%
(parent menu)
(label (format (string-constant jump-to-defn) (defn-name defn)))
(callback (λ (x y)
(send editor set-position (defn-start-pos defn))))))))
(let* ([canvas (send editor get-canvas)]
[frame (and canvas (send canvas get-frame))])
(unless (is-a? frame -frame<%>)
(let* ([tab (send frame get-current-tab)]
[language-settings (send (send tab get-definitions-text) get-next-settings)]
[new-language (drscheme:language-configuration:language-settings-language language-settings)]
[capability-info (send new-language capability-value 'drscheme:define-popup)])
(when capability-info
(let* ([current-pos (get-pos editor event)]
[current-word (and current-pos (get-current-word editor current-pos))]
[defn (and current-word
(ormap (λ (defn) (and (string=? current-word (defn-name defn))
defn))
(get-definitions (car capability-info)
#f
editor)))])
(when defn
(new separator-menu-item% (parent menu))
(new menu-item%
(parent menu)
(label (format (string-constant jump-to-defn) (defn-name defn)))
(callback (λ (x y)
(send editor set-position (defn-start-pos defn))))))))))))
(old menu editor event))))
;; get-current-word : editor number -> string
@ -649,60 +660,73 @@ module browser threading seems wrong.
(string-constant sort-by-position)
(string-constant sort-by-name))))
(define capability-info (drscheme:language:get-capability-default 'drscheme:define-popup))
(inherit set-message set-hidden?)
(define/public (language-changed new-language)
(set! capability-info (send new-language capability-value 'drscheme:define-popup))
(cond
[capability-info
(set-message #f (cdr capability-info))
(set-hidden? #f)]
[else
(set-hidden? #t)]))
(define/override (fill-popup menu reset)
(let* ([text (send frame get-definitions-text)]
[unsorted-defns (get-definitions (not sort-by-name?) text)]
[defns (if sort-by-name?
(sort
unsorted-defns
(λ (x y) (string-ci<=? (defn-name x) (defn-name y))))
unsorted-defns)])
(make-object menu:can-restore-menu-item% sorting-name
menu
(λ (x y)
(change-sorting-order)))
(make-object separator-menu-item% menu)
(if (null? defns)
(send (make-object menu:can-restore-menu-item%
(string-constant no-definitions-found)
menu
void)
enable #f)
(let loop ([defns defns])
(unless (null? defns)
(let* ([defn (car defns)]
[checked?
(let ([t-start (send text get-start-position)]
[t-end (send text get-end-position)]
[d-start (defn-start-pos defn)]
[d-end (defn-end-pos defn)])
(or (<= t-start d-start t-end)
(<= t-start d-end t-end)
(<= d-start t-start t-end d-end)))]
[item
(make-object (if checked?
menu:can-restore-checkable-menu-item%
menu:can-restore-menu-item%)
(gui-utils:trim-string (defn-name defn) 200)
menu
(λ (x y)
(reset)
(send text set-position (defn-start-pos defn) (defn-start-pos defn))
(let ([canvas (send text get-canvas)])
(when canvas
(send canvas focus)))))])
(when checked?
(send item check #t))
(loop (cdr defns))))))))
(when capability-info
(let* ([text (send frame get-definitions-text)]
[unsorted-defns (get-definitions (car capability-info)
(not sort-by-name?)
text)]
[defns (if sort-by-name?
(sort
unsorted-defns
(λ (x y) (string-ci<=? (defn-name x) (defn-name y))))
unsorted-defns)])
(make-object menu:can-restore-menu-item% sorting-name
menu
(λ (x y)
(change-sorting-order)))
(make-object separator-menu-item% menu)
(if (null? defns)
(send (make-object menu:can-restore-menu-item%
(string-constant no-definitions-found)
menu
void)
enable #f)
(let loop ([defns defns])
(unless (null? defns)
(let* ([defn (car defns)]
[checked?
(let ([t-start (send text get-start-position)]
[t-end (send text get-end-position)]
[d-start (defn-start-pos defn)]
[d-end (defn-end-pos defn)])
(or (<= t-start d-start t-end)
(<= t-start d-end t-end)
(<= d-start t-start t-end d-end)))]
[item
(make-object (if checked?
menu:can-restore-checkable-menu-item%
menu:can-restore-menu-item%)
(gui-utils:trim-string (defn-name defn) 200)
menu
(λ (x y)
(reset)
(send text set-position (defn-start-pos defn) (defn-start-pos defn))
(let ([canvas (send text get-canvas)])
(when canvas
(send canvas focus)))))])
(when checked?
(send item check #t))
(loop (cdr defns)))))))))
(super-new (label "(define ...)"))))
;; defn = (make-defn number string number number)
(define-struct defn (indent name start-pos end-pos))
(define tag-string "(define")
;; get-definitions : boolean text -> (listof defn)
(define (get-definitions indent? text)
(define (get-definitions tag-string indent? text)
(let* ([min-indent 0]
[defs (let loop ([pos 0])
(let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)])
@ -1262,6 +1286,13 @@ module browser threading seems wrong.
(set! save-init-shown? mod?))
(update-tab-label current-tab)))
;; update-define-popup : -> void
;; brings the (define ...) popup in sync with the main drscheme window
(define/public (update-define-popup)
(let ([settings (send definitions-text get-next-settings)])
(send func-defs-canvas language-changed
(drscheme:language-configuration:language-settings-language settings))))
;; update-save-message : -> void
;; sets the save message. If input is #f, uses the frame's
;; title.
@ -1455,47 +1486,46 @@ module browser threading seems wrong.
(close-current-tab)))))
(super file-menu:between-close-and-quit file-menu))
[define/override file-menu:save-string (λ () (string-constant save-definitions))]
[define/override file-menu:save-as-string (λ () (string-constant save-definitions-as))]
[define/override file-menu:between-save-as-and-print
(λ (file-menu)
(let ([sub-menu (make-object menu% (string-constant save-other) file-menu)])
(make-object menu:can-restore-menu-item%
(string-constant save-definitions-as-text)
sub-menu
(λ (_1 _2)
(let ([filename (send definitions-text put-file #f #f)])
(when filename
(send definitions-text save-file/gui-error filename 'text)))))
(make-object menu:can-restore-menu-item%
(string-constant save-interactions)
sub-menu
(λ (_1 _2)
(send interactions-text save-file/gui-error)))
(make-object menu:can-restore-menu-item%
(string-constant save-interactions-as)
sub-menu
(λ (_1 _2)
(let ([filename (send interactions-text put-file #f #f)])
(when filename
(send interactions-text save-file/gui-error filename 'standard)))))
(make-object menu:can-restore-menu-item%
(string-constant save-interactions-as-text)
sub-menu
(λ (_1 _2)
(let ([filename (send interactions-text put-file #f #f)])
(when filename
(send interactions-text save-file/gui-error filename 'text)))))
(make-object separator-menu-item% file-menu)
(set! logging-menu-item
(make-object menu:can-restore-menu-item%
(string-constant log-definitions-and-interactions)
file-menu
(λ (x y)
(if logging
(stop-logging)
(start-logging)))))
(make-object separator-menu-item% file-menu)))]
(define/override (file-menu:save-string) (string-constant save-definitions))
(define/override (file-menu:save-as-string) (string-constant save-definitions-as))
(define/override (file-menu:between-save-as-and-print file-menu)
(let ([sub-menu (make-object menu% (string-constant save-other) file-menu)])
(make-object menu:can-restore-menu-item%
(string-constant save-definitions-as-text)
sub-menu
(λ (_1 _2)
(let ([filename (send definitions-text put-file #f #f)])
(when filename
(send definitions-text save-file/gui-error filename 'text)))))
(make-object menu:can-restore-menu-item%
(string-constant save-interactions)
sub-menu
(λ (_1 _2)
(send interactions-text save-file/gui-error)))
(make-object menu:can-restore-menu-item%
(string-constant save-interactions-as)
sub-menu
(λ (_1 _2)
(let ([filename (send interactions-text put-file #f #f)])
(when filename
(send interactions-text save-file/gui-error filename 'standard)))))
(make-object menu:can-restore-menu-item%
(string-constant save-interactions-as-text)
sub-menu
(λ (_1 _2)
(let ([filename (send interactions-text put-file #f #f)])
(when filename
(send interactions-text save-file/gui-error filename 'text)))))
(make-object separator-menu-item% file-menu)
(set! logging-menu-item
(make-object menu:can-restore-menu-item%
(string-constant log-definitions-and-interactions)
file-menu
(λ (x y)
(if logging
(stop-logging)
(start-logging)))))
(make-object separator-menu-item% file-menu)))
[define/override file-menu:print-string (λ () (string-constant print-definitions))]
(define/override (file-menu:between-print-and-close file-menu)
@ -2068,6 +2098,7 @@ module browser threading seems wrong.
(restore-visible-tab-regions)
(update-save-message)
(update-save-button)
(update-define-popup)
(send definitions-text update-frame-filename)
(send definitions-text set-delegate old-delegate)
@ -2512,10 +2543,60 @@ module browser threading seems wrong.
;
;
;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key)))
(define capability-menu-items (make-hash-table))
(define/public (register-capability-menu-item key menu)
(let ([items (send menu get-items)])
(when (null? items)
(error 'register-capability-menu-item "menu ~e has no items" menu))
(drscheme:language:register-capability key (flat-contract boolean?) #t)
(let* ([menu-item (car (last-pair items))]
[this-one (list menu-item (length items) key)]
[old-ones (hash-table-get capability-menu-items menu (λ () '()))])
(hash-table-put! capability-menu-items menu (cons this-one old-ones)))))
(define/private (update-items/capability menu)
(let ([new-items (get-items/capability menu)])
(for-each (λ (i) (send i delete)) (send menu get-items))
(for-each (λ (i) (send i restore)) new-items)))
(define/private (get-items/capability menu)
(let loop ([capability-items
(reverse
(hash-table-get capability-menu-items menu (λ () '())))]
[all-items (send menu get-items)]
[i 0])
(cond
[(null? capability-items) all-items]
[else
(let* ([cap-item-list (car capability-items)]
[cap-item (list-ref cap-item-list 0)]
[cap-num (list-ref cap-item-list 1)]
[cap-key (list-ref cap-item-list 2)])
(cond
[(= cap-num i)
(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))))]
[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)))]))]
[else (cons (car all-items)
(loop capability-items
(cdr all-items)
(+ i 1)))]))])))
(define/private (get-current-capability-value key)
(let* ([language-settings (send (get-definitions-text) get-next-settings)]
[new-language (drscheme:language-configuration:language-settings-language language-settings)])
(send new-language capability-value key)))
(define special-menu 'special-menu-not-yet-init)
(define/public (get-special-menu) special-menu)
(define/private (initialize-menus)
(let* ([mb (get-menu-bar)]
[language-menu-on-demand
@ -2532,7 +2613,10 @@ module browser threading seems wrong.
(λ (_1 _2)
(let ([text (get-focus-object)])
(when (is-a? text scheme:text<%>)
(method text)))))])
(method text)))))]
[show/hide-capability-menus
(λ ()
(for-each (λ (menu) (update-items/capability menu)) (send (get-menu-bar) get-items)))])
(make-object menu:can-restore-menu-item%
(string-constant choose-language-menu-item-label)
@ -2544,6 +2628,7 @@ module browser threading seems wrong.
this)])
(when new-settings
(send definitions-text set-next-settings new-settings)
(update-define-popup)
(preferences:set
drscheme:language-configuration:settings-preferences-symbol
new-settings))))
@ -2649,7 +2734,13 @@ module browser threading seems wrong.
[else (send text uncomment-selection)]))))))
(set! special-menu
(make-object (get-menu%) (string-constant special-menu) mb))
(new (get-menu%)
[label (string-constant special-menu)]
[parent mb]
[demand-callback
(λ (special-menu)
;; just here for convience -- it actually works on all menus, not just the special menu
(show/hide-capability-menus))]))
(let ([has-editor-on-demand
(λ (menu-item)
@ -2783,17 +2874,22 @@ module browser threading seems wrong.
special-menu callback
#f #f
has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-fraction special-menu)
(make-object c% (string-constant insert-large-letters...)
special-menu
(λ (x y) (insert-large-semicolon-letters))
#f #f
has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-large-letters special-menu)
(make-object c% (string-constant insert-lambda)
special-menu
(λ (x y) (insert-lambda))
#\\
#f
has-editor-on-demand))
has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-lambda special-menu))
(make-object separator-menu-item% (get-show-menu))
@ -2981,6 +3077,7 @@ module browser threading seems wrong.
(update-save-message)
(update-save-button)
(update-define-popup)
(cond
[filename

2
collects/framework/private/scheme.ss
View File

@ -1263,7 +1263,7 @@
(ormap
(λ (x)
(text-between-equal? x text backward-match before-whitespace-pos))
'("cond" "provide/contract")))
'("cond" "field" "provide/contract")))
(change-to #\())]))]
[(not (zero? before-whitespace-pos))
;; this is the first thing in the sequence

85
collects/mrlib/name-message.ss
View File

@ -38,6 +38,12 @@
stretchable-width stretchable-height
get-top-level-window refresh)
(define hidden? #f)
(define/public (set-hidden? d?)
(unless (eq? hidden? d?)
(set! hidden? d?)
(refresh)))
(define paths #f)
;; label : string
@ -87,38 +93,39 @@
(send i enable #f))))
(define/override (on-event evt)
(let-values ([(max-x max-y) (get-size)])
(let ([inside? (and (not (send evt leaving?))
(<= 0 (send evt get-x) max-x)
(<= 0 (send evt get-y) max-y))])
(unless (eq? inside? mouse-over?)
(set! mouse-over? inside?)
(refresh))))
(cond
[(send evt button-down?)
(let-values ([(width height) (get-size)]
[(reset) (lambda ()
(set! mouse-grabbed? #f)
(set! mouse-over? #f)
(refresh))])
(set! mouse-over? #t)
(set! mouse-grabbed? #t)
(let ([menu (make-object popup-menu% #f
(lambda x
(reset)))])
(fill-popup menu reset)
;; Refresh the screen (wait for repaint)
(set! paint-sema (make-semaphore))
(refresh)
(yield paint-sema)
(set! paint-sema #f)
;; Popup menu
(popup-menu menu
0
height)))]))
(unless hidden?
(let-values ([(max-x max-y) (get-size)])
(let ([inside? (and (not (send evt leaving?))
(<= 0 (send evt get-x) max-x)
(<= 0 (send evt get-y) max-y))])
(unless (eq? inside? mouse-over?)
(set! mouse-over? inside?)
(refresh))))
(cond
[(send evt button-down?)
(let-values ([(width height) (get-size)]
[(reset) (lambda ()
(set! mouse-grabbed? #f)
(set! mouse-over? #f)
(refresh))])
(set! mouse-over? #t)
(set! mouse-grabbed? #t)
(let ([menu (make-object popup-menu% #f
(lambda x
(reset)))])
(fill-popup menu reset)
;; Refresh the screen (wait for repaint)
(set! paint-sema (make-semaphore))
(refresh)
(yield paint-sema)
(set! paint-sema #f)
;; Popup menu
(popup-menu menu
0
height)))])))
(define paint-sema #f)
@ -134,8 +141,18 @@
(semaphore-post paint-sema))
(let ([dc (get-dc)])
(let-values ([(w h) (get-client-size)])
(when (and (> w 5) (> h 5))
(draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed?)))))
(cond
[hidden?
(let ([pen (send dc get-pen)]
[brush (send dc get-brush)])
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(send dc draw-rectangle 0 0 w h)
(send dc set-pen pen)
(send dc set-brush brush))]
[else
(when (and (> w 5) (> h 5))
(draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed?))]))))
(super-new [style '(transparent)])
(update-min-sizes)

6
collects/profj/tool.ss
View File

@ -149,6 +149,12 @@
(define (java-lang-mixin level name number one-line dyn?)
(when dyn? (dynamic? #t))
(class* object% (drscheme:language:language<%>)
(define/public (capability-value s)
(cond
[(regexp-match #rx"^drscheme:special:" (format "~a" s)) #f]
[(memq s '(slideshow:special-menu drscheme:define-popup)) #f]
[else
(drscheme:language:get-capability-default s)]))
(define/public (first-opened) (void))
(define/public (order-manuals x)

5
collects/slideshow/tool.ss
View File

@ -621,8 +621,9 @@ pict snip :
(super-new)
(inherit get-special-menu)
(add-special-menu-item (get-special-menu) this)))
(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))))
(define slideshow-dragable%
(class panel:horizontal-dragable%