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

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

22
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,7 +1023,22 @@
(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")
@ -243,6 +244,10 @@
(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
(λ (filename) (λ (filename)

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

@ -943,16 +943,16 @@ 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=
@ -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

@ -898,6 +898,42 @@
"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

79
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 (cond
[(send evt button-down?) [(send evt button-down?)
(let-values ([(width height) (get-size)] (let-values ([(width height) (get-size)]
[(reset) (lambda () [(reset) (lambda ()
(set! mouse-grabbed? #f) (set! mouse-grabbed? #f)
(set! mouse-over? #f) (set! mouse-over? #f)
(refresh))]) (refresh))])
(set! mouse-over? #t) (set! mouse-over? #t)
(set! mouse-grabbed? #t) (set! mouse-grabbed? #t)
(let ([menu (make-object popup-menu% #f (let ([menu (make-object popup-menu% #f
(lambda x (lambda x
(reset)))]) (reset)))])
(fill-popup menu reset) (fill-popup menu reset)
;; Refresh the screen (wait for repaint) ;; Refresh the screen (wait for repaint)
(set! paint-sema (make-semaphore)) (set! paint-sema (make-semaphore))
(refresh) (refresh)
(yield paint-sema) (yield paint-sema)
(set! paint-sema #f) (set! paint-sema #f)
;; Popup menu ;; Popup menu
(popup-menu menu (popup-menu menu
0 0
height)))])) 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%