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 doc.txt "doc.txt")
(define tools '(("tool.ss"))) (define tools '(("tool.ss")))
(define tool-names '("Algol 60"))) (define tool-names '("Algol 60")))

1
collects/algol60/tool.ss
View File

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

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

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

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

@ -53,6 +53,8 @@
render-value/format render-value/format
render-value render-value
capability-value
create-executable create-executable
get-language-position get-language-position
@ -504,6 +506,9 @@
(inherit get-module get-transformer-module use-namespace-require/copy? (inherit get-module get-transformer-module use-namespace-require/copy?
get-init-code use-mred-launcher get-reader) 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 (first-opened) (void))
(define/public (get-comment-character) (values "; " #\;)) (define/public (get-comment-character) (values "; " #\;))
(define/public (order-manuals x) (values x #t)) (define/public (order-manuals x) (values x #t))
@ -1018,8 +1023,23 @@
(ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) (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") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "cmdline.ss") (lib "cmdline.ss")
(lib "contract.ss")
"drsig.ss" "drsig.ss"
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
@ -242,6 +243,10 @@
warnings-panel)))) warnings-panel))))
(drscheme:debug:add-prefs-panel) (drscheme:debug:add-prefs-panel)
(install-help-browser-preference-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 (handler:current-create-new-window
(let ([drscheme-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. ;; continue to evaluate from the correct port.
(define get-sexp/syntax/eof #f) (define get-sexp/syntax/eof #f)
(define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler= (define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler=
(send context disable-evaluation) (send context disable-evaluation)
(send context reset-offer-kill) (send context reset-offer-kill)
(send context set-breakables (get-user-thread) (get-user-custodian)) (send context set-breakables (get-user-thread) (get-user-custodian))
(reset-pretty-print-width) (reset-pretty-print-width)
(when should-collect-garbage? (when should-collect-garbage?
(set! should-collect-garbage? #f) (set! should-collect-garbage? #f)
(collect-garbage)) (collect-garbage))
(set! in-evaluation? #t) (set! in-evaluation? #t)
(update-running #t) (update-running #t)
(set! need-interaction-cleanup? #t) (set! need-interaction-cleanup? #t)
(run-in-evaluation-thread (run-in-evaluation-thread
(λ () ; =User=, =Handler=, =No-Breaks= (λ () ; =User=, =Handler=, =No-Breaks=
(let* ([settings (current-language-settings)] (let* ([settings (current-language-settings)]
@ -1386,7 +1386,7 @@ TODO
click-delta))) click-delta)))
(unless (is-default-settings? user-language-settings) (unless (is-default-settings? user-language-settings)
(insert/delta this (string-append " " (string-constant custom)) dark-green-delta)) (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 (for-each
(λ (fn) (λ (fn)
@ -1394,7 +1394,7 @@ TODO
(string-append (string-constant teachpack) ": ") (string-append (string-constant teachpack) ": ")
welcome-delta) welcome-delta)
(insert/delta this fn dark-green-delta) (insert/delta this fn dark-green-delta)
(insert/delta this (format ".~n") welcome-delta)) (insert/delta this ".\n" welcome-delta))
(map path->string (map path->string
(drscheme:teachpack:teachpack-cache-filenames (drscheme:teachpack:teachpack-cache-filenames
user-teachpack-cache))) user-teachpack-cache)))
@ -1415,7 +1415,7 @@ TODO
(insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta) (insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta)
(let-values ([(before after) (let-values ([(before after)
(insert/delta this (string-constant drscheme) click-delta drs-font-delta)]) (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) welcome-delta)
(set-clickback before after (set-clickback before after
(λ args (drscheme:app:about-drscheme)) (λ 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" "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" "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.") "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)) (or/c number? (symbols 'infinity))
. -> . . -> .
any)) 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<%>))) (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 (module unit mzscheme
(require (lib "unitsig.ss") (require (lib "contract.ss")
(lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "file.ss") (lib "file.ss")
(lib "etc.ss") (lib "etc.ss")
@ -602,19 +603,29 @@ module browser threading seems wrong.
(keymap:add-to-right-button-menu (keymap:add-to-right-button-menu
(λ (menu editor event) (λ (menu editor event)
(when (is-a? editor text%) (when (is-a? editor text%)
(let* ([current-pos (get-pos editor event)] (let* ([canvas (send editor get-canvas)]
[current-word (and current-pos (get-current-word editor current-pos))] [frame (and canvas (send canvas get-frame))])
[defn (and current-word (unless (is-a? frame -frame<%>)
(ormap (λ (defn) (and (string=? current-word (defn-name defn)) (let* ([tab (send frame get-current-tab)]
defn)) [language-settings (send (send tab get-definitions-text) get-next-settings)]
(get-definitions #f editor)))]) [new-language (drscheme:language-configuration:language-settings-language language-settings)]
(when defn [capability-info (send new-language capability-value 'drscheme:define-popup)])
(new separator-menu-item% (parent menu)) (when capability-info
(new menu-item% (let* ([current-pos (get-pos editor event)]
(parent menu) [current-word (and current-pos (get-current-word editor current-pos))]
(label (format (string-constant jump-to-defn) (defn-name defn))) [defn (and current-word
(callback (λ (x y) (ormap (λ (defn) (and (string=? current-word (defn-name defn))
(send editor set-position (defn-start-pos 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)))) (old menu editor event))))
;; get-current-word : editor number -> string ;; get-current-word : editor number -> string
@ -649,60 +660,73 @@ module browser threading seems wrong.
(string-constant sort-by-position) (string-constant sort-by-position)
(string-constant sort-by-name)))) (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) (define/override (fill-popup menu reset)
(let* ([text (send frame get-definitions-text)] (when capability-info
[unsorted-defns (get-definitions (not sort-by-name?) text)] (let* ([text (send frame get-definitions-text)]
[defns (if sort-by-name? [unsorted-defns (get-definitions (car capability-info)
(sort (not sort-by-name?)
unsorted-defns text)]
(λ (x y) (string-ci<=? (defn-name x) (defn-name y)))) [defns (if sort-by-name?
unsorted-defns)]) (sort
(make-object menu:can-restore-menu-item% sorting-name unsorted-defns
menu (λ (x y) (string-ci<=? (defn-name x) (defn-name y))))
(λ (x y) unsorted-defns)])
(change-sorting-order))) (make-object menu:can-restore-menu-item% sorting-name
(make-object separator-menu-item% menu) menu
(if (null? defns) (λ (x y)
(send (make-object menu:can-restore-menu-item% (change-sorting-order)))
(string-constant no-definitions-found) (make-object separator-menu-item% menu)
menu (if (null? defns)
void) (send (make-object menu:can-restore-menu-item%
enable #f) (string-constant no-definitions-found)
(let loop ([defns defns]) menu
(unless (null? defns) void)
(let* ([defn (car defns)] enable #f)
[checked? (let loop ([defns defns])
(let ([t-start (send text get-start-position)] (unless (null? defns)
[t-end (send text get-end-position)] (let* ([defn (car defns)]
[d-start (defn-start-pos defn)] [checked?
[d-end (defn-end-pos defn)]) (let ([t-start (send text get-start-position)]
(or (<= t-start d-start t-end) [t-end (send text get-end-position)]
(<= t-start d-end t-end) [d-start (defn-start-pos defn)]
(<= d-start t-start t-end d-end)))] [d-end (defn-end-pos defn)])
[item (or (<= t-start d-start t-end)
(make-object (if checked? (<= t-start d-end t-end)
menu:can-restore-checkable-menu-item% (<= d-start t-start t-end d-end)))]
menu:can-restore-menu-item%) [item
(gui-utils:trim-string (defn-name defn) 200) (make-object (if checked?
menu menu:can-restore-checkable-menu-item%
(λ (x y) menu:can-restore-menu-item%)
(reset) (gui-utils:trim-string (defn-name defn) 200)
(send text set-position (defn-start-pos defn) (defn-start-pos defn)) menu
(let ([canvas (send text get-canvas)]) (λ (x y)
(when canvas (reset)
(send canvas focus)))))]) (send text set-position (defn-start-pos defn) (defn-start-pos defn))
(when checked? (let ([canvas (send text get-canvas)])
(send item check #t)) (when canvas
(loop (cdr defns)))))))) (send canvas focus)))))])
(when checked?
(send item check #t))
(loop (cdr defns)))))))))
(super-new (label "(define ...)")))) (super-new (label "(define ...)"))))
;; defn = (make-defn number string number number) ;; defn = (make-defn number string number number)
(define-struct defn (indent name start-pos end-pos)) (define-struct defn (indent name start-pos end-pos))
(define tag-string "(define")
;; get-definitions : boolean text -> (listof defn) ;; get-definitions : boolean text -> (listof defn)
(define (get-definitions indent? text) (define (get-definitions tag-string indent? text)
(let* ([min-indent 0] (let* ([min-indent 0]
[defs (let loop ([pos 0]) [defs (let loop ([pos 0])
(let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)]) (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?)) (set! save-init-shown? mod?))
(update-tab-label current-tab))) (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 ;; update-save-message : -> void
;; sets the save message. If input is #f, uses the frame's ;; sets the save message. If input is #f, uses the frame's
;; title. ;; title.
@ -1455,47 +1486,46 @@ module browser threading seems wrong.
(close-current-tab))))) (close-current-tab)))))
(super file-menu:between-close-and-quit file-menu)) (super file-menu:between-close-and-quit file-menu))
[define/override file-menu:save-string (λ () (string-constant save-definitions))] (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:save-as-string) (string-constant save-definitions-as))
[define/override file-menu:between-save-as-and-print (define/override (file-menu:between-save-as-and-print file-menu)
(λ (file-menu) (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)])
(let ([sub-menu (make-object menu% (string-constant save-other) file-menu)]) (make-object menu:can-restore-menu-item%
(make-object menu:can-restore-menu-item% (string-constant save-definitions-as-text)
(string-constant save-definitions-as-text) sub-menu
sub-menu (λ (_1 _2)
(λ (_1 _2) (let ([filename (send definitions-text put-file #f #f)])
(let ([filename (send definitions-text put-file #f #f)]) (when filename
(when filename (send definitions-text save-file/gui-error filename 'text)))))
(send definitions-text save-file/gui-error filename 'text))))) (make-object menu:can-restore-menu-item%
(make-object menu:can-restore-menu-item% (string-constant save-interactions)
(string-constant save-interactions) sub-menu
sub-menu (λ (_1 _2)
(λ (_1 _2) (send interactions-text save-file/gui-error)))
(send interactions-text save-file/gui-error))) (make-object menu:can-restore-menu-item%
(make-object menu:can-restore-menu-item% (string-constant save-interactions-as)
(string-constant save-interactions-as) sub-menu
sub-menu (λ (_1 _2)
(λ (_1 _2) (let ([filename (send interactions-text put-file #f #f)])
(let ([filename (send interactions-text put-file #f #f)]) (when filename
(when filename (send interactions-text save-file/gui-error filename 'standard)))))
(send interactions-text save-file/gui-error filename 'standard))))) (make-object menu:can-restore-menu-item%
(make-object menu:can-restore-menu-item% (string-constant save-interactions-as-text)
(string-constant save-interactions-as-text) sub-menu
sub-menu (λ (_1 _2)
(λ (_1 _2) (let ([filename (send interactions-text put-file #f #f)])
(let ([filename (send interactions-text put-file #f #f)]) (when filename
(when filename (send interactions-text save-file/gui-error filename 'text)))))
(send interactions-text save-file/gui-error filename 'text))))) (make-object separator-menu-item% file-menu)
(make-object separator-menu-item% file-menu) (set! logging-menu-item
(set! logging-menu-item (make-object menu:can-restore-menu-item%
(make-object menu:can-restore-menu-item% (string-constant log-definitions-and-interactions)
(string-constant log-definitions-and-interactions) file-menu
file-menu (λ (x y)
(λ (x y) (if logging
(if logging (stop-logging)
(stop-logging) (start-logging)))))
(start-logging))))) (make-object separator-menu-item% file-menu)))
(make-object separator-menu-item% file-menu)))]
[define/override file-menu:print-string (λ () (string-constant print-definitions))] [define/override file-menu:print-string (λ () (string-constant print-definitions))]
(define/override (file-menu:between-print-and-close file-menu) (define/override (file-menu:between-print-and-close file-menu)
@ -2068,6 +2098,7 @@ module browser threading seems wrong.
(restore-visible-tab-regions) (restore-visible-tab-regions)
(update-save-message) (update-save-message)
(update-save-button) (update-save-button)
(update-define-popup)
(send definitions-text update-frame-filename) (send definitions-text update-frame-filename)
(send definitions-text set-delegate old-delegate) (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 special-menu 'special-menu-not-yet-init)
(define/public (get-special-menu) special-menu) (define/public (get-special-menu) special-menu)
(define/private (initialize-menus) (define/private (initialize-menus)
(let* ([mb (get-menu-bar)] (let* ([mb (get-menu-bar)]
[language-menu-on-demand [language-menu-on-demand
@ -2532,7 +2613,10 @@ module browser threading seems wrong.
(λ (_1 _2) (λ (_1 _2)
(let ([text (get-focus-object)]) (let ([text (get-focus-object)])
(when (is-a? text scheme:text<%>) (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% (make-object menu:can-restore-menu-item%
(string-constant choose-language-menu-item-label) (string-constant choose-language-menu-item-label)
@ -2544,6 +2628,7 @@ module browser threading seems wrong.
this)]) this)])
(when new-settings (when new-settings
(send definitions-text set-next-settings new-settings) (send definitions-text set-next-settings new-settings)
(update-define-popup)
(preferences:set (preferences:set
drscheme:language-configuration:settings-preferences-symbol drscheme:language-configuration:settings-preferences-symbol
new-settings)))) new-settings))))
@ -2649,7 +2734,13 @@ module browser threading seems wrong.
[else (send text uncomment-selection)])))))) [else (send text uncomment-selection)]))))))
(set! special-menu (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 (let ([has-editor-on-demand
(λ (menu-item) (λ (menu-item)
@ -2783,17 +2874,22 @@ module browser threading seems wrong.
special-menu callback special-menu callback
#f #f #f #f
has-editor-on-demand) has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-fraction special-menu)
(make-object c% (string-constant insert-large-letters...) (make-object c% (string-constant insert-large-letters...)
special-menu special-menu
(λ (x y) (insert-large-semicolon-letters)) (λ (x y) (insert-large-semicolon-letters))
#f #f #f #f
has-editor-on-demand) has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-large-letters special-menu)
(make-object c% (string-constant insert-lambda) (make-object c% (string-constant insert-lambda)
special-menu special-menu
(λ (x y) (insert-lambda)) (λ (x y) (insert-lambda))
#\\ #\\
#f #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)) (make-object separator-menu-item% (get-show-menu))
@ -2981,6 +3077,7 @@ module browser threading seems wrong.
(update-save-message) (update-save-message)
(update-save-button) (update-save-button)
(update-define-popup)
(cond (cond
[filename [filename

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

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

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

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

6
collects/profj/tool.ss
View File

@ -149,6 +149,12 @@
(define (java-lang-mixin level name number one-line dyn?) (define (java-lang-mixin level name number one-line dyn?)
(when dyn? (dynamic? #t)) (when dyn? (dynamic? #t))
(class* object% (drscheme:language:language<%>) (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 (first-opened) (void))
(define/public (order-manuals x) (define/public (order-manuals x)

5
collects/slideshow/tool.ss
View File

@ -621,8 +621,9 @@ pict snip :
(super-new) (super-new)
(inherit get-special-menu) (inherit get-special-menu #;register-capability-menu-item)
(add-special-menu-item (get-special-menu) this))) (add-special-menu-item (get-special-menu) this)
#;(register-capability-menu-item 'slideshow:special-menu (get-special-menu))))
(define slideshow-dragable% (define slideshow-dragable%
(class panel:horizontal-dragable% (class panel:horizontal-dragable%