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.
svn: r8073
This commit is contained in:
Danny Yoo
parent
f70ea2d03a
commit
9a4d947174
|
|
@ -134,14 +134,14 @@ module browser threading seems wrong.
|
|||
(unless (string=? str "")
|
||||
(make-object separator-menu-item% menu)
|
||||
(make-object menu-item%
|
||||
(format (string-constant search-help-desk-for)
|
||||
(gui-utils:format-literal-label (string-constant search-help-desk-for)
|
||||
(shorten-str
|
||||
str
|
||||
(- 200 (string-length (string-constant search-help-desk-for)))))
|
||||
menu
|
||||
(λ x (help-desk:help-desk str #f 'keyword+index 'contains language)))
|
||||
(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
|
||||
str
|
||||
(- 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 menu-item%
|
||||
(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)
|
||||
(send editor set-position (defn-start-pos defn))))))))))))
|
||||
(old menu editor event))))
|
||||
|
|
@ -841,10 +841,8 @@ module browser threading seems wrong.
|
|||
(make-object (if checked?
|
||||
menu:can-restore-checkable-menu-item%
|
||||
menu:can-restore-menu-item%)
|
||||
(regexp-replace*
|
||||
#rx"&"
|
||||
(gui-utils:trim-string (defn-name defn) 200)
|
||||
"&&")
|
||||
(gui-utils:quote-literal-label (defn-name defn))
|
||||
|
||||
menu
|
||||
(λ (x y)
|
||||
(reset)
|
||||
|
|
@ -1268,7 +1266,7 @@ module browser threading seems wrong.
|
|||
(or (null? dir-list)
|
||||
(let ([query (message-box
|
||||
(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
|
||||
'(yes-no))])
|
||||
(cond
|
||||
|
|
@ -1279,7 +1277,7 @@ module browser threading seems wrong.
|
|||
(λ (exn)
|
||||
(message-box
|
||||
(string-constant drscheme)
|
||||
(format (string-constant error-erasing-log-directory)
|
||||
(gui-utils:format-literal-label (string-constant error-erasing-log-directory)
|
||||
(if (exn? exn)
|
||||
(format "~a" (exn-message exn))
|
||||
(format "~s" exn)))
|
||||
|
|
@ -2884,7 +2882,7 @@ module browser threading seems wrong.
|
|||
mi)
|
||||
(map (λ (name)
|
||||
(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]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
|
|
@ -2899,7 +2897,7 @@ module browser threading seems wrong.
|
|||
[callback
|
||||
(λ (_1 _2)
|
||||
(message-box (string-constant drscheme)
|
||||
(format (string-constant teachpacks-only-in-languages)
|
||||
(gui-utils:format-literal-label (string-constant teachpacks-only-in-languages)
|
||||
(apply
|
||||
string-append
|
||||
(reverse
|
||||
|
|
|
|||
|
|
@ -1910,7 +1910,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
var
|
||||
id
|
||||
(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)
|
||||
req-path))
|
||||
(connect-syntaxes req-stx var actual?)))
|
||||
|
|
@ -2115,7 +2115,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ (menu)
|
||||
(let-values ([(base name dir?) (split-path file)])
|
||||
(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)
|
||||
(callback (λ (x y) (fw:handler:edit-file file))))
|
||||
(void))))
|
||||
|
|
@ -2397,7 +2397,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ (menu)
|
||||
(instantiate menu-item% ()
|
||||
(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
|
||||
(λ (x y)
|
||||
(send-url (format "file://~a~a"
|
||||
|
|
@ -2444,7 +2444,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ (menu)
|
||||
(instantiate menu-item% ()
|
||||
(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
|
||||
(λ (x y)
|
||||
(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
|
||||
(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
|
||||
name-to-offer)))])
|
||||
(when new-str
|
||||
|
|
@ -2507,7 +2507,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(equal?
|
||||
(message-box/custom
|
||||
(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)
|
||||
(string-constant cs-rename-anyway)
|
||||
(string-constant cancel)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
[(_ (name contract docs ...) ...)
|
||||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
|
||||
(define (trim-string str size)
|
||||
(let ([str-size (string-length str)])
|
||||
(cond
|
||||
|
|
@ -34,6 +35,20 @@
|
|||
(substring str
|
||||
(- str-size post-length)
|
||||
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
|
||||
(define selected-text-color (send the-color-database find-color "black"))
|
||||
|
|
@ -264,6 +279,8 @@
|
|||
|
||||
;; manual renaming
|
||||
(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:show-busy-cursor show-busy-cursor)
|
||||
(define gui-utils:delay-action delay-action)
|
||||
|
|
@ -292,6 +309,29 @@
|
|||
"than \\var{size} by trimming the \\var{str}"
|
||||
"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?
|
||||
(-> boolean?)
|
||||
()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user