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

added framework:gui-utils:quote-literal-label and framework:gui-utils:format-literal-string to escape ampersands in string labels. Updated drscheme/syncheck and drscheme/private/unit to use these functions.

Browse Source 
svn: r8073
This commit is contained in:
Danny Yoo 2007-12-19 21:38:55 +00:00
parent f70ea2d03a
commit 9a4d947174
3 changed files with 55 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -134,14 +134,14 @@ module browser threading seems wrong.
(unless (string=? str "") (unless (string=? str "")
(make-object separator-menu-item% menu) (make-object separator-menu-item% menu)
(make-object menu-item% (make-object menu-item%
(format (string-constant search-help-desk-for) (gui-utils:format-literal-label (string-constant search-help-desk-for)
(shorten-str (shorten-str
str str
(- 200 (string-length (string-constant search-help-desk-for))))) (- 200 (string-length (string-constant search-help-desk-for)))))
menu menu
(λ x (help-desk:help-desk str #f 'keyword+index 'contains language))) (λ x (help-desk:help-desk str #f 'keyword+index 'contains language)))
(make-object menu-item% (make-object menu-item%
(format (string-constant exact-lucky-search-help-desk-for) (gui-utils:format-literal-label (string-constant exact-lucky-search-help-desk-for)
(shorten-str (shorten-str
str str
(- 200 (string-length (string-constant exact-lucky-search-help-desk-for))))) (- 200 (string-length (string-constant exact-lucky-search-help-desk-for)))))
@ -756,7 +756,7 @@ module browser threading seems wrong.
(new separator-menu-item% (parent menu)) (new separator-menu-item% (parent menu))
(new menu-item% (new menu-item%
(parent menu) (parent menu)
(label (format (string-constant jump-to-defn) (defn-name defn))) (label (gui-utils:format-literal-label (string-constant jump-to-defn) (defn-name defn)))
(callback (λ (x y) (callback (λ (x y)
(send editor set-position (defn-start-pos defn)))))))))))) (send editor set-position (defn-start-pos defn))))))))))))
(old menu editor event)))) (old menu editor event))))
@ -841,10 +841,8 @@ module browser threading seems wrong.
(make-object (if checked? (make-object (if checked?
menu:can-restore-checkable-menu-item% menu:can-restore-checkable-menu-item%
menu:can-restore-menu-item%) menu:can-restore-menu-item%)
(regexp-replace* (gui-utils:quote-literal-label (defn-name defn))
#rx"&"
(gui-utils:trim-string (defn-name defn) 200)
"&&")
menu menu
(λ (x y) (λ (x y)
(reset) (reset)
@ -1268,7 +1266,7 @@ module browser threading seems wrong.
(or (null? dir-list) (or (null? dir-list)
(let ([query (message-box (let ([query (message-box
(string-constant drscheme) (string-constant drscheme)
(format (string-constant erase-log-directory-contents) log-directory) (gui-utils:format-literal-label (string-constant erase-log-directory-contents) log-directory)
this this
'(yes-no))]) '(yes-no))])
(cond (cond
@ -1279,7 +1277,7 @@ module browser threading seems wrong.
(λ (exn) (λ (exn)
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(format (string-constant error-erasing-log-directory) (gui-utils:format-literal-label (string-constant error-erasing-log-directory)
(if (exn? exn) (if (exn? exn)
(format "~a" (exn-message exn)) (format "~a" (exn-message exn))
(format "~s" exn))) (format "~s" exn)))
@ -2884,7 +2882,7 @@ module browser threading seems wrong.
mi) mi)
(map (λ (name) (map (λ (name)
(new menu:can-restore-menu-item% (new menu:can-restore-menu-item%
[label (format (string-constant clear-teachpack) name)] [label (gui-utils:format-literal-label (string-constant clear-teachpack) name)]
[parent language-menu] [parent language-menu]
[callback [callback
(λ (item evt) (λ (item evt)
@ -2899,7 +2897,7 @@ module browser threading seems wrong.
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(format (string-constant teachpacks-only-in-languages) (gui-utils:format-literal-label (string-constant teachpacks-only-in-languages)
(apply (apply
string-append string-append
(reverse (reverse

12
collects/drscheme/syncheck.ss
View File

@ -1910,7 +1910,7 @@ If the namespace does not, they are colored the unbound color.
var var
id id
(get-require-filename req-path user-namespace user-directory))) (get-require-filename req-path user-namespace user-directory)))
(add-mouse-over var (format (string-constant cs-mouse-over-import) (add-mouse-over var (fw:gui-utils:format-literal-label (string-constant cs-mouse-over-import)
(syntax-e var) (syntax-e var)
req-path)) req-path))
(connect-syntaxes req-stx var actual?))) (connect-syntaxes req-stx var actual?)))
@ -2115,7 +2115,7 @@ If the namespace does not, they are colored the unbound color.
(λ (menu) (λ (menu)
(let-values ([(base name dir?) (split-path file)]) (let-values ([(base name dir?) (split-path file)])
(instantiate menu-item% () (instantiate menu-item% ()
(label (format (string-constant cs-open-file) (path->string name))) (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
(parent menu) (parent menu)
(callback (λ (x y) (fw:handler:edit-file file)))) (callback (λ (x y) (fw:handler:edit-file file))))
(void)))) (void))))
@ -2397,7 +2397,7 @@ If the namespace does not, they are colored the unbound color.
(λ (menu) (λ (menu)
(instantiate menu-item% () (instantiate menu-item% ()
(parent menu) (parent menu)
(label (format (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry)))) (label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry))))
(callback (callback
(λ (x y) (λ (x y)
(send-url (format "file://~a~a" (send-url (format "file://~a~a"
@ -2444,7 +2444,7 @@ If the namespace does not, they are colored the unbound color.
(λ (menu) (λ (menu)
(instantiate menu-item% () (instantiate menu-item% ()
(parent menu) (parent menu)
(label (format (string-constant cs-rename-var) name-to-offer)) (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer))
(callback (callback
(λ (x y) (λ (x y)
(let ([frame-parent (find-menu-parent menu)]) (let ([frame-parent (find-menu-parent menu)])
@ -2485,7 +2485,7 @@ If the namespace does not, they are colored the unbound color.
(λ () (λ ()
(get-text-from-user (get-text-from-user
(string-constant cs-rename-id) (string-constant cs-rename-id)
(format (string-constant cs-rename-var-to) name-to-offer) (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
parent parent
name-to-offer)))]) name-to-offer)))])
(when new-str (when new-str
@ -2507,7 +2507,7 @@ If the namespace does not, they are colored the unbound color.
(equal? (equal?
(message-box/custom (message-box/custom
(string-constant check-syntax) (string-constant check-syntax)
(format (string-constant cs-name-duplication-error) (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error)
new-sym) new-sym)
(string-constant cs-rename-anyway) (string-constant cs-rename-anyway)
(string-constant cancel) (string-constant cancel)

40
collects/framework/gui-utils.ss
View File

@ -11,6 +11,7 @@
[(_ (name contract docs ...) ...) [(_ (name contract docs ...) ...)
(syntax (provide/contract (name contract) ...))])) (syntax (provide/contract (name contract) ...))]))
(define (trim-string str size) (define (trim-string str size)
(let ([str-size (string-length str)]) (let ([str-size (string-length str)])
(cond (cond
@ -34,6 +35,20 @@
(substring str (substring str
(- str-size post-length) (- str-size post-length)
str-size))]))]))) str-size))]))])))
(define maximum-string-label-length 200)
;; format-literal-label: string any* -> string
(define (format-literal-label format-str . args)
(quote-literal-label (apply format format-str args)))
;; quote-literal-label: string -> string
(define (quote-literal-label a-str)
(trim-string (regexp-replace* #rx"(&)" a-str "\\1\\1")
maximum-string-label-length))
;; selected-text-color : color ;; selected-text-color : color
(define selected-text-color (send the-color-database find-color "black")) (define selected-text-color (send the-color-database find-color "black"))
@ -264,6 +279,8 @@
;; manual renaming ;; manual renaming
(define gui-utils:trim-string trim-string) (define gui-utils:trim-string trim-string)
(define gui-utils:quote-literal-label quote-literal-label)
(define gui-utils:format-literal-label format-literal-label)
(define gui-utils:next-untitled-name next-untitled-name) (define gui-utils:next-untitled-name next-untitled-name)
(define gui-utils:show-busy-cursor show-busy-cursor) (define gui-utils:show-busy-cursor show-busy-cursor)
(define gui-utils:delay-action delay-action) (define gui-utils:delay-action delay-action)
@ -292,6 +309,29 @@
"than \\var{size} by trimming the \\var{str}" "than \\var{size} by trimming the \\var{str}"
"and inserting an ellispses into it.") "and inserting an ellispses into it.")
(gui-utils:quote-literal-label
(string?
. ->d .
(lambda (str)
(and/c string?
(lambda (str)
((string-length str) . <= . 200)))))
"Constructs a string whose ampersand characters are"
"escaped; the label is also trimmed to <= 200"
"characters.")
(gui-utils:format-literal-label
((string?)
(listof any/c)
. ->d* .
(lambda (str . rest)
(and/c string?
(lambda (str)
((string-length str) . <= . 200)))))
"Formats a string whose ampersand characters are"
"escaped; the label is also trimmed to <= 200"
"characters.")
(gui-utils:cancel-on-right? (gui-utils:cancel-on-right?
(-> boolean?) (-> boolean?)
() ()