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

...

Browse Source 
original commit: 2b3ae05e3c7e4c9a448ec98c15236f1c2f82259e
This commit is contained in:
Robby Findler 2001-09-07 04:52:49 +00:00
parent 738f26ba20
commit 729b587b6c
11 changed files with 336 additions and 257 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/framework/private/editor.ss
View File

@ -2,6 +2,7 @@
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
(lib "string-constant.ss" "string-constants")
"sig.ss" "sig.ss"
"../gui-utils-sig.ss" "../gui-utils-sig.ss"
"../macro.ss" "../macro.ss"
@ -51,10 +52,10 @@
(and (if (equal? filename (get-filename)) (and (if (equal? filename (get-filename))
(if (save-file-out-of-date?) (if (save-file-out-of-date?)
(gui-utils:get-choice (gui-utils:get-choice
"The file has beeen modified since it was last saved. Overwrite the modifications?" (string-constant file-has-been-modified)
"Overwrite" (string-constant overwrite-file-button-label)
"Cancel" (string-constant cancel)
"Warning" (string-constant warning)
#f #f
(get-top-level-focus-window)) (get-top-level-focus-window))
#t) #t)
@ -403,11 +404,12 @@
(set! auto-save-out-of-date? #f)) (set! auto-save-out-of-date? #f))
(begin (begin
(message-box (message-box
"Warning" (string-constant warning)
(format "Error autosaving ~s.~n~a~n~a" (string-append
(or orig-name "Untitled") (format (string-constant error-autosaving)
"Autosaving is turned off" (or orig-name (string-constant untitled)))
"until the file is saved.")) "\n"
(string-constant autosaving-turned-off)))
(set! auto-save-error? #t))))))] (set! auto-save-error? #t))))))]
[define remove-autosave [define remove-autosave
(lambda () (lambda ()

14
collects/framework/private/exit.ss
View File

@ -1,5 +1,6 @@
(module exit mzscheme (module exit mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "string-constant.ss" "string-constants")
(lib "class.ss") (lib "class.ss")
"sig.ss" "sig.ss"
"../gui-utils-sig.ss" "../gui-utils-sig.ss"
@ -52,13 +53,14 @@
(if (preferences:get 'framework:verify-exit) (if (preferences:get 'framework:verify-exit)
(let*-values ([(w capw) (let*-values ([(w capw)
(if (eq? (system-type) 'windows) (if (eq? (system-type) 'windows)
(values "exit" "Exit") (values (string-constant exit-lc) (string-constant exit-cap))
(values "quit" "Quit"))] (values (string-constant quit-lc) (string-constant quit-cap)))]
[(message) [(message)
(string-append "Are you sure you want to " (format (string-constant are-you-sure-format) w)]
w [(user-says) (gui-utils:get-choice message capw
"?")] (string-constant cancel)
[(user-says) (gui-utils:get-choice message capw "Cancel" "Warning" #f (string-constant warning)
#f
(frame-exiting))]) (frame-exiting))])
user-says) user-says)
#t)) #t))

99
collects/framework/private/finder.ss
View File

@ -1,6 +1,7 @@
(module finder mzscheme (module finder mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
"sig.ss" "sig.ss"
"../gui-utils-sig.ss" "../gui-utils-sig.ss"
(lib "class100.ss") (lib "class100.ss")
@ -31,7 +32,7 @@
(if (regexp-match-exact? filter name) (if (regexp-match-exact? filter name)
#t #t
(begin (begin
(message-box "Error" msg) (message-box (string-constant error) msg)
#f))))) #f)))))
(define last-directory #f) (define last-directory #f)
@ -216,14 +217,14 @@
(if (directory-exists? file) (if (directory-exists? file)
(set-directory (normal-case-path (normalize-path file))) (set-directory (normal-case-path (normalize-path file)))
(message-box (message-box
"Error" (string-constant error)
"You must specify a file name")))] (string-constant must-specify-a-filename))))]
[(and save-mode? [(and save-mode?
non-empty? non-empty?
file-filter file-filter
(not (regexp-match-exact? file-filter name))) (not (regexp-match-exact? file-filter name)))
(message-box "Error" file-filter-msg)] (message-box (string-constant error) file-filter-msg)]
[else [else
@ -248,10 +249,8 @@
(if (and (not save-mode?) (not file-in-edit)) (if (and (not save-mode?) (not file-in-edit))
(message-box (message-box
"Error" (string-constant error)
(string-append "The file \"" (format (string-constant file-does-not-exist) dir-name))
dir-name
"\" does not exist."))
; saving a file, which may exist, or ; saving a file, which may exist, or
; opening an existing file ; opening an existing file
@ -259,25 +258,23 @@
(if (or (not save-mode?) (if (or (not save-mode?)
(not (file-exists? file)) (not (file-exists? file))
replace-ok? replace-ok?
(eq? (message-box "Warning" (eq? (message-box
(string-append (string-constant warning)
"The file " (format
file (string-constant ask-because-file-exists)
" already exists. " file)
"Replace it?") #f
#f '(yes-no))
'(yes-no))
'yes)) 'yes))
(let ([normal-path (let ([normal-path
(with-handlers (with-handlers
([(lambda (_) #t) ([(lambda (_) #t)
(lambda (_) (lambda (_)
(message-box (message-box
"Warning" (string-constant warning)
(string-append (format
"The file " (string-constant dne-or-cycle)
file file))
" contains nonexistent directory or cycle."))
#f)]) #f)])
(normal-case-path (normal-case-path
(normalize-path file)))]) (normalize-path file)))])
@ -329,7 +326,9 @@
[on-close (lambda () #f)]) [on-close (lambda () #f)])
(sequence (sequence
(super-init (if save-mode? "Put file" "Get file") (super-init (if save-mode?
(string-constant put-file)
(string-constant get-file))
parent-win parent-win
default-width default-width
default-height default-height
@ -484,7 +483,7 @@
(keymap:call/text-keymap-initializer (keymap:call/text-keymap-initializer
(lambda () (lambda ()
(make-object text-field% (make-object text-field%
"Full pathname" (string-constant full-pathname)
directory-panel directory-panel
(lambda (txt evt) (lambda (txt evt)
(when (eq? (send evt get-event-type) 'text-field-enter) (when (eq? (send evt get-event-type) 'text-field-enter)
@ -527,7 +526,7 @@
(when (eq? (system-type) 'unix) (when (eq? (system-type) 'unix)
(let ([dot-cb (let ([dot-cb
(make-object check-box% (make-object check-box%
"Show files and directories that begin with a dot" (string-constant show-dot-files)
dot-panel dot-panel
(lambda (x y) (do-period-in/exclusion x y)))]) (lambda (x y) (do-period-in/exclusion x y)))])
(send dot-panel stretchable-height #f) (send dot-panel stretchable-height #f)
@ -542,7 +541,7 @@
(send result-list stretchable-width #t)) (send result-list stretchable-width #t))
(make-object button% (make-object button%
"Up directory" (string-constant up-directory-button-label)
top-panel top-panel
(lambda (button evt) (do-updir))) (lambda (button evt) (do-updir)))
@ -559,29 +558,35 @@
[add-button (when multi-mode? [add-button (when multi-mode?
(make-object horizontal-panel% add-panel) (make-object horizontal-panel% add-panel)
(make-object button% (make-object button%
"Add" (string-constant add-button-label)
add-panel add-panel
(lambda (x y) (do-add))))] (lambda (x y) (do-add))))]
[add-all-button (when multi-mode? [add-all-button (when multi-mode?
(begin0 (begin0
(make-object button% (make-object button%
"Add all" (string-constant add-all-button-label)
add-panel add-panel
(lambda (x y) (do-add-all))) (lambda (x y) (do-add-all)))
(make-object horizontal-panel% add-panel)))] (make-object horizontal-panel% add-panel)))]
[remove-button (when multi-mode? [remove-button (when multi-mode?
(make-object horizontal-panel% remove-panel) (make-object horizontal-panel% remove-panel)
(begin0 (begin0
(make-object button% "Remove" remove-panel (lambda (x y) (do-remove))) (make-object button%
(string-constant remove-button-label)
remove-panel
(lambda (x y) (do-remove)))
(make-object horizontal-panel% remove-panel)))]) (make-object horizontal-panel% remove-panel)))])
(sequence (sequence
(make-object vertical-panel% bottom-panel)) (make-object vertical-panel% bottom-panel))
(private-field (private-field
[ok-button [ok-button
(make-object button% "OK" bottom-panel (make-object button% (string-constant ok) bottom-panel
(lambda (x y) (do-ok)) (lambda (x y) (do-ok))
(if multi-mode? '() '(border)))] (if multi-mode? '() '(border)))]
[cancel-button (make-object button% "Cancel" bottom-panel (lambda (x y) (do-cancel)))]) [cancel-button (make-object button%
(string-constant cancel)
bottom-panel
(lambda (x y) (do-cancel)))])
(sequence (sequence
(make-object grow-box-spacer-pane% bottom-panel) (make-object grow-box-spacer-pane% bottom-panel)
@ -617,9 +622,9 @@
[name #f] [name #f]
[in-directory #f] [in-directory #f]
[replace? #f] [replace? #f]
[prompt "Select file"] [prompt (string-constant select-file)]
[filter #f] [filter #f]
[filter-msg "Invalid form"] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (not in-directory) (let* ([directory (if (and (not in-directory)
(string? name)) (string? name))
@ -647,9 +652,9 @@
(opt-lambda (opt-lambda
(result-box (result-box
[directory #f] [directory #f]
[prompt "Select file"] [prompt (string-constant select-file)]
[filter #f] [filter #f]
[filter-msg "Bad name"] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let ([saved-directory last-directory]) (let ([saved-directory last-directory])
(make-object finder-dialog% (make-object finder-dialog%
@ -669,9 +674,9 @@
(make-common (make-common
(opt-lambda (result-box (opt-lambda (result-box
[directory #f] [directory #f]
[prompt "Select files"] [prompt (string-constant select-files)]
[filter #f] [filter #f]
[filter-msg "Bad name"] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(make-object (make-object
finder-dialog% finder-dialog%
@ -694,9 +699,9 @@
(opt-lambda ([name #f] (opt-lambda ([name #f]
[directory #f] [directory #f]
[replace? #f] [replace? #f]
[prompt "Select file"] [prompt (string-constant select-file)]
[filter #f] [filter #f]
[filter-msg "That filename does not have the right form."] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (not directory) (let* ([directory (if (and (not directory)
(string? name)) (string? name))
@ -723,18 +728,20 @@
[name (file-name-from-path f)]) [name (file-name-from-path f)])
(cond (cond
[(not (and (string? dir) (directory-exists? dir))) [(not (and (string? dir) (directory-exists? dir)))
(message-box "Error" "That directory does not exist.") (message-box (string-constant error)
(string-constant dir-dne))
#f] #f]
[(or (not name) (equal? name "")) [(or (not name) (equal? name ""))
(message-box "Error" "Empty filename.") (message-box (string-constant error)
(string-constant empty-filename))
#f] #f]
[else f])))))) [else f]))))))
(define std-get-file (define std-get-file
(opt-lambda ([directory #f] (opt-lambda ([directory #f]
[prompt "Select file"] [prompt (string-constant select-file)]
[filter #f] [filter #f]
[filter-msg "That filename does not have the right form."] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let ([f (get-file (let ([f (get-file
prompt prompt
@ -746,10 +753,12 @@
(let ([f (normalize-path f)]) (let ([f (normalize-path f)])
(cond (cond
[(directory-exists? f) [(directory-exists? f)
(message-box "Error" "That is a directory name.") (message-box (string-constant error)
(string-constant that-is-dir-name))
#f] #f]
[(not (file-exists? f)) [(not (file-exists? f))
(message-box "Error" "File does not exist.") (message-box (string-constant error)
(string-constant file-dne))
#f] #f]
[else f])) [else f]))
#f) #f)

76
collects/framework/private/frame.ss
View File

@ -1,6 +1,7 @@
(module frame mzscheme (module frame mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
(lib "include.ss") (lib "include.ss")
@ -55,11 +56,11 @@
(reverse (move-to-back name (reverse items))))] (reverse (move-to-back name (reverse items))))]
[re-ordered [re-ordered
(move-to-front (move-to-front
"File" (string-constant file-menu)
(move-to-front (move-to-front
"Edit" (string-constant edit-menu)
(move-to-back (move-to-back
"Help" (string-constant help-menu)
items)))]) items)))])
(for-each (lambda (item) (send item delete)) items) (for-each (lambda (item) (send item delete)) items)
(for-each (lambda (item) (send item restore)) re-ordered))) (for-each (lambda (item) (send item restore)) re-ordered)))
@ -151,7 +152,8 @@
(super-instantiate ()) (super-instantiate ())
(accept-drop-files #t) (accept-drop-files #t)
(make-object menu% "&Windows" (make-object (get-menu-bar%) this)) (make-object menu% (string-constant windows-menu-label)
(make-object (get-menu-bar%) this))
(reorder-menus this) (reorder-menus this)
(send (group:get-the-frame-group) insert-frame this) (send (group:get-the-frame-group) insert-frame this)
[define panel (make-root-area-container (get-area-container%) this)] [define panel (make-root-area-container (get-area-container%) this)]
@ -159,8 +161,8 @@
[define get-area-container (lambda () panel)] [define get-area-container (lambda () panel)]
(set! after-init? #t))) (set! after-init? #t)))
(define locked-message "Read only") (define locked-message (string-constant read-only))
(define unlocked-message "Read/Write") (define unlocked-message (string-constant read/write))
(define lock-canvas% (define lock-canvas%
(class100 canvas% (parent . args) (class100 canvas% (parent . args)
@ -331,7 +333,7 @@
; only for CVSers ; only for CVSers
(when show-memory-text? (when show-memory-text?
(let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))] (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))]
[button (make-object button% "Collect" panel [button (make-object button% (string-constant collect-button-label) panel
(lambda x (lambda x
(collect-garbage) (collect-garbage)
(update-memory-text)))] (update-memory-text)))]
@ -529,11 +531,11 @@
(let ([b (icon:get-anchor-bitmap)]) (let ([b (icon:get-anchor-bitmap)])
(if (and #f (send b ok?)) (if (and #f (send b ok?))
b b
"Auto-extend Selection")) (string-constant auto-extend-selection)))
(get-info-panel))] (get-info-panel))]
[define overwrite-message [define overwrite-message
(make-object message% (make-object message%
"Overwrite" (string-constant overwrite)
(get-info-panel))] (get-info-panel))]
[define position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))] [define position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
[define position-edit (make-object text%)] [define position-edit (make-object text%)]
@ -703,8 +705,8 @@
(begin (begin
(send edit end-edit-sequence) (send edit end-edit-sequence)
(message-box (message-box
"Error Reverting" (string-constant error-reverting)
(format "could not read ~a" filename))))))) (format (string-constant could-not-read) filename)))))))
#t))] #t))]
[define file-menu:create-revert? (lambda () #t)] [define file-menu:create-revert? (lambda () #t)]
[define file-menu:save-callback (lambda (item control) [define file-menu:save-callback (lambda (item control)
@ -739,9 +741,12 @@
(let ([edit (get-edit-target-object)]) (let ([edit (get-edit-target-object)])
(send menu-item enable (and edit (is-a? edit editor<%>)))))]) (send menu-item enable (and edit (is-a? edit editor<%>)))))])
(make-object c% "Insert Text Box" edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand) (make-object c% (string-constant insert-text-box-item)
(make-object c% "Insert Pasteboard Box" edit-menu (edit-menu:do 'insert-pasteboard-box) #f #f on-demand) edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand)
(make-object c% "Insert Image..." edit-menu (edit-menu:do 'insert-image) #f #f on-demand)))] (make-object c% (string-constant insert-pb-box-item)
edit-menu (edit-menu:do 'insert-pasteboard-box) #f #f on-demand)
(make-object c% (string-constant insert-image-item)
edit-menu (edit-menu:do 'insert-image) #f #f on-demand)))]
(override edit-menu:between-select-all-and-find) (override edit-menu:between-select-all-and-find)
@ -768,7 +773,8 @@
(when (and edit (when (and edit
(is-a? edit editor<%>)) (is-a? edit editor<%>))
(send edit auto-wrap (not (send edit auto-wrap))))))]) (send edit auto-wrap (not (send edit auto-wrap))))))])
(make-object c% "Wrap Text" edit-menu callback #f #f on-demand)) (make-object c% (string-constant wrap-text-item)
edit-menu callback #f #f on-demand))
(make-object separator-menu-item% edit-menu))] (make-object separator-menu-item% edit-menu))]
@ -776,7 +782,8 @@
[define help-menu:about-callback [define help-menu:about-callback
(lambda (menu evt) (lambda (menu evt)
(message-box (application:current-app-name) (message-box (application:current-app-name)
(format "Welcome to ~a" (application:current-app-name))))] (format (string-constant welcome-to-something)
(application:current-app-name))))]
[define help-menu:about-string (lambda () (application:current-app-name))] [define help-menu:about-string (lambda () (application:current-app-name))]
[define help-menu:create-about? (lambda () #t)] [define help-menu:create-about? (lambda () #t)]
@ -836,7 +843,7 @@
(let* ([to-be-searched-text (send frame get-text-to-search)] (let* ([to-be-searched-text (send frame get-text-to-search)]
[to-be-searched-canvas (send to-be-searched-text get-canvas)] [to-be-searched-canvas (send to-be-searched-text get-canvas)]
[dialog (make-object dialog% "Find and Replace" frame)] [dialog (make-object dialog% (string-constant find-and-replace) frame)]
[copy-text [copy-text
(lambda (from to) (lambda (from to)
@ -862,20 +869,20 @@
[find-panel (make-object horizontal-panel% dialog)] [find-panel (make-object horizontal-panel% dialog)]
[find-message (make-object message% "Find" find-panel)] [find-message (make-object message% (string-constant find) find-panel)]
[f-text (make-object text-keymap/editor%)] [f-text (make-object text-keymap/editor%)]
[find-canvas (make-object editor-canvas% find-panel f-text [find-canvas (make-object editor-canvas% find-panel f-text
'(hide-hscroll hide-vscroll))] '(hide-hscroll hide-vscroll))]
[replace-panel (make-object horizontal-panel% dialog)] [replace-panel (make-object horizontal-panel% dialog)]
[replace-message (make-object message% "Replace" replace-panel)] [replace-message (make-object message% (string-constant replace) replace-panel)]
[r-text (make-object text-keymap/editor%)] [r-text (make-object text-keymap/editor%)]
[replace-canvas (make-object editor-canvas% replace-panel r-text [replace-canvas (make-object editor-canvas% replace-panel r-text
'(hide-hscroll hide-vscroll))] '(hide-hscroll hide-vscroll))]
[button-panel (make-object horizontal-panel% dialog)] [button-panel (make-object horizontal-panel% dialog)]
[pref-check (make-object check-box% [pref-check (make-object check-box%
"Use separate dialog for searching" (string-constant use-separate-dialog-for-searching)
dialog dialog
(lambda (pref-check evt) (lambda (pref-check evt)
(preferences:set (preferences:set
@ -889,24 +896,25 @@
(send find-edit start-searching) (send find-edit start-searching)
(copy-text r-text replace-edit))] (copy-text r-text replace-edit))]
[find-button (make-object button% "Find" button-panel [find-button (make-object button% (string-constant find) button-panel
(lambda x (lambda x
(update-texts) (update-texts)
(send frame search-again)) (send frame search-again))
'(border))] '(border))]
[replace-button (make-object button% "Replace" button-panel [replace-button (make-object button% (string-constant replace) button-panel
(lambda x (lambda x
(update-texts) (update-texts)
(send frame replace)))] (send frame replace)))]
[replace-button (make-object button% "Replace && Find Again" button-panel [replace-button (make-object button% (string-constant replace&find-again)
button-panel
(lambda x (lambda x
(update-texts) (update-texts)
(send frame replace&search)))] (send frame replace&search)))]
[replace-button (make-object button% "Replace to End" button-panel [replace-button (make-object button% (string-constant replace-to-end) button-panel
(lambda x (lambda x
(update-texts) (update-texts)
(send frame replace-all)))] (send frame replace-all)))]
[close-button (make-object button% "Close" button-panel [close-button (make-object button% (string-constant close) button-panel
(lambda x (lambda x
(send to-be-searched-canvas force-display-focus #f) (send to-be-searched-canvas force-display-focus #f)
(send dialog show #f)))]) (send dialog show #f)))])
@ -1393,23 +1401,25 @@
[define middle-right-panel (make-object vertical-pane% search-panel)] [define middle-right-panel (make-object vertical-pane% search-panel)]
[define search-button (make-object button% [define search-button (make-object button%
"Search" (string-constant find)
middle-left-panel middle-left-panel
(lambda args (search-again)))] (lambda args (search-again)))]
[define replace&search-button (make-object button% [define replace&search-button (make-object button%
"Replace && Search" (string-constant replace&find-again)
middle-middle-panel middle-middle-panel
(lambda x (replace&search)))] (lambda x (replace&search)))]
[define replace-button (make-object button% "Replace" middle-left-panel (lambda x (replace)))] [define replace-button (make-object button% (string-constant replace)
middle-left-panel (lambda x (replace)))]
[define replace-all-button (make-object button% [define replace-all-button (make-object button%
"Replace To End" (string-constant replace-to-end)
middle-middle-panel middle-middle-panel
(lambda x (replace-all)))] (lambda x (replace-all)))]
[define dir-radio (make-object radio-box% [define dir-radio (make-object radio-box%
#f #f
(list "Forward" "Backward") (list (string-constant forward)
(string-constant backward))
middle-right-panel middle-right-panel
(lambda (dir-radio evt) (lambda (dir-radio evt)
(let ([forward (if (= (send dir-radio get-selection) 0) (let ([forward (if (= (send dir-radio get-selection) 0)
@ -1417,7 +1427,7 @@
'backward)]) 'backward)])
(set-search-direction forward) (set-search-direction forward)
(reset-search-anchor (get-text-to-search)))))] (reset-search-anchor (get-text-to-search)))))]
[define close-button (make-object button% "Hide" [define close-button (make-object button% (string-constant hide)
middle-right-panel middle-right-panel
(lambda args (hide-search)))] (lambda args (hide-search)))]
[define hidden? #f] [define hidden? #f]
@ -1476,7 +1486,7 @@
(if (string? fn) (if (string? fn)
fn fn
(get-label))) (get-label)))
"Close" (string-constant close)
#t #t
this) this)
[(continue) #t] [(continue) #t]

7
collects/framework/private/group.ss
View File

@ -1,6 +1,7 @@
(module group mzscheme (module group mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
"sig.ss" "sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
@ -38,7 +39,7 @@
(and menu-bar (and menu-bar
(let ([menus (send menu-bar get-items)]) (let ([menus (send menu-bar get-items)])
(ormap (lambda (x) (ormap (lambda (x)
(if (string=? "&Windows" (send x get-label)) (if (string=? (string-constant windows-menu-label) (send x get-label))
x x
#f)) #f))
menus)))))] menus)))))]
@ -58,7 +59,7 @@
[define (update-windows-menus) [define (update-windows-menus)
(let* ([windows (length windows-menus)] (let* ([windows (length windows-menus)]
[default-name "Untitled"] [default-name (string-constant untitled)]
[get-name [get-name
(lambda (frame) (lambda (frame)
(let ([label (send frame get-label)]) (let ([label (send frame get-label)])

24
collects/framework/private/keymap.ss
View File

@ -1,5 +1,6 @@
(module keymap mzscheme (module keymap mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
"sig.ss" "sig.ss"
"../macro.ss" "../macro.ss"
(lib "class.ss") (lib "class.ss")
@ -597,8 +598,8 @@
(call/text-keymap-initializer (call/text-keymap-initializer
(lambda () (lambda ()
(get-text-from-user (get-text-from-user
"Goto Line" (string-constant goto-line)
"Goto Line:")))]) (string-constant goto-line))))])
(when (string? num-str) (when (string? num-str)
(let ([line-num (inexact->exact (string->number num-str))]) (let ([line-num (inexact->exact (string->number num-str))])
(cond (cond
@ -610,10 +611,11 @@
(send edit set-position pos))] (send edit set-position pos))]
[else [else
(message-box (message-box
"Goto Line" (string-constant goto-line)
(format "~a is not a valid line number. It must be an integer between 1 and ~a" (format
num-str (string-constant goto-line-invalid-number)
(+ (send edit last-line) 1)))])))) num-str
(+ (send edit last-line) 1)))]))))
#t)] #t)]
[goto-position [goto-position
@ -622,12 +624,12 @@
(call/text-keymap-initializer (call/text-keymap-initializer
(lambda () (lambda ()
(get-text-from-user (get-text-from-user
"Goto Position" (string-constant goto-position)
"Goto Position:")))]) (string-constant goto-position))))])
(if (string? num-str) (if (string? num-str)
(let ([pos (string->number num-str)]) (let ([pos (string->number num-str)])
(if pos (when pos
(send edit set-position (sub1 pos)))))) (send edit set-position (sub1 pos))))))
#t)] #t)]
[repeater [repeater
(lambda (n edit) (lambda (n edit)

10
collects/framework/private/main.ss
View File

@ -158,16 +158,8 @@
(exit:insert-on-callback (exit:insert-on-callback
(lambda () (lambda ()
(with-handlers ([(lambda (x) (void)) (preferences:save)))
(lambda (exn)
(message-box
"Saving Prefs"
(format "Error saving preferences: ~a"
(exn-message exn))))])
(preferences:save))))
;(wx:application-file-handler edit-file) ;; how to handle drag and drop?
(preferences:read) (preferences:read)
;; reset these -- they are only for the test suite. ;; reset these -- they are only for the test suite.

152
collects/framework/private/preferences.ss
View File

@ -1,8 +1,9 @@
(module preferences mzscheme (module preferences mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
"sig" "sig.ss"
"../prefs-file-sig.ss" "../prefs-file-sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "pretty.ss") (lib "pretty.ss")
@ -63,7 +64,7 @@
p p
(lambda () (lambda ()
(raise exn))) (raise exn)))
(message-box (format "Error unmarshalling ~a preference" p) (message-box (format (string-constant error-unmarshalling) p)
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
(format "~s" exn))))))))) (format "~s" exn)))))))))
@ -166,11 +167,7 @@
[unmarshalled [unmarshalled
(if (checker unmarsh) (if (checker unmarsh)
unmarsh unmarsh
(begin in-default-value)]
'(printf
"WARNING: rejected saved default ~s for ~s; using ~s instead"
unmarsh p in-default-value)
in-default-value))]
[pref (if (check-callbacks p unmarshalled) [pref (if (check-callbacks p unmarshalled)
unmarshalled unmarshalled
in-default-value)]) in-default-value)])
@ -210,7 +207,7 @@
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(lambda (exn) (lambda (exn)
(message-box (message-box
"Error saving preferences" (string-constant error-saving-preferences)
(exn-message exn)))]) (exn-message exn)))])
(call-with-output-file (prefs-file:get-preferences-filename) (call-with-output-file (prefs-file:get-preferences-filename)
(lambda (p) (lambda (p)
@ -222,25 +219,31 @@
(let/ec k (let/ec k
(let ([err (let ([err
(lambda (input msg) (lambda (input msg)
(message-box "Preferences" (message-box
(let* ([max-len 150] (string-constant preferences)
[s1 (format "~s" input)] (let* ([max-len 150]
[ell "..."] [s1 (format "~s" input)]
[s2 (if (<= (string-length s1) max-len) [ell "..."]
s1 [s2 (if (<= (string-length s1) max-len)
(string-append s1
(substring s1 0 (- max-len (string-append
(string-length ell))) (substring s1 0 (- max-len
ell))]) (string-length ell)))
(format "found bad pref in ~a: ~a~n~a" ell))])
preferences-filename msg s2))))]) (string-append
(format (string-constant found-bad-pref) preferences-filename)
"\n"
msg
s2)))
(k #f))])
(let ([input (with-handlers (let ([input (with-handlers
([(lambda (exn) #t) ([not-break-exn?
(lambda (exn) (lambda (exn)
(message-box (message-box
"Error reading preferences" (string-constant error-reading-preferences)
(format "Error reading preferences~n~a" (string-append
(exn-message exn))) (string-constant error-reading-preferences)
(format "\n~a" (exn-message exn))))
(k #f))]) (k #f))])
(call-with-input-file preferences-filename (call-with-input-file preferences-filename
read read
@ -248,28 +251,14 @@
(if (eof-object? input) (if (eof-object? input)
(void) (void)
(let loop ([input input]) (let loop ([input input])
(cond (when (pair? input)
[(pair? input) (let ([pre-pref (car input)])
(let ([err-msg (if (and (list? pre-pref)
(let/ec k (= 2 (length pre-pref)))
(let ([first (car input)]) (parse-pref (car pre-pref) (cadr pre-pref))
(unless (pair? first) (err input (string-constant expected-list-of-length2))))
(k "expected pair of pair")) (loop (cdr input)))))))))
(let ([arg1 (car first)]
[t1 (cdr first)])
(unless (pair? t1)
(k "expected pair of two pairs"))
(let ([arg2 (car t1)]
[t2 (cdr t1)])
(unless (null? t2)
(k "expected null after two pairs"))
(parse-pref arg1 arg2)
(k #f)))))])
(when err-msg
(err input err-msg)))
(loop (cdr input))]
[(null? input) (void)]
[else (err input "expected a pair")])))))))
;; read-from-file-to-ht : string hash-table -> void ;; read-from-file-to-ht : string hash-table -> void
(define (read-from-file-to-ht filename ht) (define (read-from-file-to-ht filename ht)
@ -320,7 +309,7 @@
(define (local-add-general-panel) (define (local-add-general-panel)
(add-panel (add-panel
"General" (string-constant general-prefs-panel-label)
(lambda (parent) (lambda (parent)
(let* ([main (make-object vertical-panel% parent)] (let* ([main (make-object vertical-panel% parent)]
[make-check [make-check
@ -337,36 +326,39 @@
(send c set-value (pref->bool v))))))] (send c set-value (pref->bool v))))))]
[id (lambda (x) x)]) [id (lambda (x) x)])
(send main set-alignment 'left 'center) (send main set-alignment 'left 'center)
(make-check 'framework:highlight-parens "Highlight between matching parens" id id) (make-check 'framework:highlight-parens (string-constant highlight-parens) id id)
(make-check 'framework:fixup-parens "Correct parens" id id) (make-check 'framework:fixup-parens (string-constant fixup-parens) id id)
(make-check 'framework:paren-match "Flash paren match" id id) (make-check 'framework:paren-match (string-constant flash-paren-match) id id)
(make-check 'framework:autosaving-on? "Auto-save files" id id) (make-check 'framework:autosaving-on? (string-constant auto-save-files) id id)
(make-check 'framework:delete-forward? "Map delete to backspace" not not) (make-check 'framework:delete-forward? (string-constant map-delete-to-backspace)
not not)
;; not exposed to the user anymore. Only left in for automated testing. (make-check 'framework:verify-exit (string-constant verify-exit) id id)
;(make-check 'framework:file-dialogs "Use platform-specific file dialogs" (make-check 'framework:verify-change-format
;(lambda (x) (if x 'std 'common)) (string-constant ask-before-changing-format)
;(lambda (x) (eq? x 'std))) id id)
(make-check 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers)
id id)
(make-check 'framework:verify-exit "Verify exit" id id) (make-check 'framework:show-status-line (string-constant show-status-line) id id)
(make-check 'framework:verify-change-format "Ask before changing save format" id id) (make-check 'framework:line-offsets (string-constant count-from-one) id id)
(make-check 'framework:auto-set-wrap? "Wrap words in editor buffers" id id) (make-check 'framework:display-line-numbers
(string-constant display-line-numbers)
(make-check 'framework:show-status-line "Show status-line" id id) id id)
(make-check 'framework:line-offsets "Count line and column numbers from one" id id) (make-check 'framework:menu-bindings (string-constant enable-keybindings-in-menus)
(make-check 'framework:display-line-numbers "Display line numbers in buffer; not character offsets" id id) id id)
(make-check 'framework:menu-bindings "Enable keybindings in menus" id id)
(unless (eq? (system-type) 'unix) (unless (eq? (system-type) 'unix)
(make-check 'framework:print-output-mode "Automatically print to postscript file" (make-check 'framework:print-output-mode
(string-constant automatically-to-ps)
(lambda (b) (lambda (b)
(if b 'postscript 'standard)) (if b 'postscript 'standard))
(lambda (n) (eq? 'postscript n)))) (lambda (n) (eq? 'postscript n))))
'(when (eq? (system-type) 'windows) '(when (eq? (system-type) 'windows)
(make-check 'framework:windows-mdi "Use MDI Windows" id id)) (make-check 'framework:windows-mdi (string-constant use-mdi) id id))
(make-check 'framework:search-using-dialog? (make-check 'framework:search-using-dialog?
"Use separate dialog for searching" (string-constant separate-dialog-for-searching)
id id) id id)
main))) main)))
@ -427,10 +419,10 @@
number?) number?)
font-size-entry) font-size-entry)
(add-panel (add-panel
"Default Fonts" (string-constant default-fonts)
(lambda (parent) (lambda (parent)
(letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)] (letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
[ex-string "The quick brown fox jumped over the lazy dogs."] [ex-string (string-constant font-example-string)]
[main (make-object vertical-panel% parent)] [main (make-object vertical-panel% parent)]
[fonts (cons font-default-string (get-face-list))] [fonts (cons font-default-string (get-face-list))]
[make-family-panel [make-family-panel
@ -467,13 +459,13 @@
horiz)] horiz)]
[button [button
(make-object button% (make-object button%
"Change" (string-constant change-font-button-label)
horiz horiz
(lambda (button evt) (lambda (button evt)
(let ([new-value (let ([new-value
(get-choices-from-user (get-choices-from-user
"Fonts" (string-constant fonts)
(format "Please choose a new ~a font" (format (string-constant choose-a-new-font)
name) name)
fonts)]) fonts)])
(when new-value (when new-value
@ -527,7 +519,7 @@
font-default-size))] font-default-size))]
[size-slider [size-slider
(make-object slider% (make-object slider%
"Size" (string-constant font-size-slider-label)
1 127 1 127
size-panel size-panel
(lambda (slider evt) (lambda (slider evt)
@ -543,7 +535,7 @@
(send size-slider set-value value)) (send size-slider set-value value))
#t)) #t))
(for-each (lambda (f) (f initial-font-size)) set-edit-fonts) (for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
(make-object message% "Restart to see font changes" main) (make-object message% (string-constant restart-to-see-font-changes) main)
main)))) main))))
(set! local-add-font-panel void)) (set! local-add-font-panel void))
@ -589,7 +581,7 @@
(sub1 (length ppanels))))))))]) (sub1 (length ppanels))))))))])
(sequence (sequence
(apply super-init args))) (apply super-init args)))
"Preferences")] (string-constant preferences))]
[panel (make-object vertical-panel% frame)] [panel (make-object vertical-panel% frame)]
[popup-callback [popup-callback
(lambda (choice command-event) (lambda (choice command-event)
@ -598,7 +590,7 @@
(ppanel-panel (list-ref ppanels (send choice get-selection))))))] (ppanel-panel (list-ref ppanels (send choice get-selection))))))]
[make-popup-menu [make-popup-menu
(lambda () (lambda ()
(let ([menu (make-object choice% "Category" (let ([menu (make-object choice% (string-constant preferences-category)
(map ppanel-title ppanels) (map ppanel-title ppanels)
panel popup-callback)]) panel popup-callback)])
(send menu stretchable-width #f) (send menu stretchable-width #f)
@ -636,11 +628,13 @@
[ok-callback (lambda args [ok-callback (lambda args
(save) (save)
(hide-dialog))] (hide-dialog))]
[ok-button (make-object button% "OK" bottom-panel ok-callback '(border))] [ok-button (make-object button% (string-constant ok)
bottom-panel ok-callback '(border))]
[cancel-callback (lambda args [cancel-callback (lambda args
(hide-dialog) (hide-dialog)
(-read))] (-read))]
[cancel-button (make-object button% "Cancel" bottom-panel cancel-callback)] [cancel-button (make-object button% (string-constant cancel)
bottom-panel cancel-callback)]
[grow-box-space (make-object grow-box-spacer-pane% bottom-panel)]) [grow-box-space (make-object grow-box-spacer-pane% bottom-panel)])
(send ok-button min-width (send cancel-button get-width)) (send ok-button min-width (send cancel-button get-width))
(send* bottom-panel (send* bottom-panel

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

@ -2,7 +2,8 @@
;; 6/30/95 ;; 6/30/95
(module scheme mzscheme (module scheme mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
"sig" "sig"
@ -505,7 +506,7 @@
(cond (cond
[(let ([real-start (cdr (find-offset end))]) [(let ([real-start (cdr (find-offset end))])
(and (<= (+ 3 real-start) (last-position)) (and (<= (+ 3 real-start) (last-position))
(string=? ";;" (string=? ";;;"
(get-text real-start (get-text real-start
(+ 2 real-start))))) (+ 2 real-start)))))
(void)] (void)]
@ -970,7 +971,7 @@
(define (add-preferences-panel) (define (add-preferences-panel)
(preferences:add-panel (preferences:add-panel
"Indenting" (string-constant indenting-prefs-panel-label)
(lambda (p) (lambda (p)
(let*-values (let*-values
([(get-keywords) ([(get-keywords)
@ -994,8 +995,8 @@
(keymap:call/text-keymap-initializer (keymap:call/text-keymap-initializer
(lambda () (lambda ()
(get-text-from-user (get-text-from-user
(string-append "Enter new " keyword-type "-like keyword:") (format (string-constant enter-new-keyword) keyword-type)
(string-append keyword-type " Keyword"))))]) (format (string-constant x-keyword) keyword-type))))])
(when new-one (when new-one
(let ([parsed (with-handlers ((exn:read? (lambda (x) #f))) (let ([parsed (with-handlers ((exn:read? (lambda (x) #f)))
(read (open-input-string new-one)))]) (read (open-input-string new-one)))])
@ -1004,13 +1005,15 @@
(hash-table-get (preferences:get 'framework:tabify) (hash-table-get (preferences:get 'framework:tabify)
parsed parsed
(lambda () #f))) (lambda () #f)))
(message-box "Error" (message-box (string-constant error)
(format "\"~a\" is already a specially indented keyword" parsed))] (format (string-constant already-used-keyword) parsed))]
[(symbol? parsed) [(symbol? parsed)
(hash-table-put! (preferences:get 'framework:tabify) (hash-table-put! (preferences:get 'framework:tabify)
parsed keyword-symbol) parsed keyword-symbol)
(send list-box append (symbol->string parsed))] (send list-box append (symbol->string parsed))]
[else (message-box "Error" (format "expected a symbol, found: ~a" new-one))]))))))] [else (message-box
(string-constant error)
(format (string-constant expected-a-symbol) new-one))]))))))]
[delete-callback [delete-callback
(lambda (list-box) (lambda (list-box)
(lambda (button command) (lambda (button command)
@ -1023,11 +1026,13 @@
[make-column [make-column
(lambda (string symbol keywords) (lambda (string symbol keywords)
(let* ([vert (make-object vertical-panel% main-panel)] (let* ([vert (make-object vertical-panel% main-panel)]
[_ (make-object message% (string-append string "-like Keywords") vert)] [_ (make-object message% (format (string-constant x-like-keywords) string) vert)]
[box (make-object list-box% #f keywords vert void '(multiple))] [box (make-object list-box% #f keywords vert void '(multiple))]
[button-panel (make-object horizontal-panel% vert)] [button-panel (make-object horizontal-panel% vert)]
[add-button (make-object button% "Add" button-panel (add-callback string symbol box))] [add-button (make-object button% (string-constant add-keyword)
[delete-button (make-object button% "Remove" button-panel (delete-callback box))]) button-panel (add-callback string symbol box))]
[delete-button (make-object button% (string-constant remove-keyword)
button-panel (delete-callback box))])
(send* button-panel (send* button-panel
(set-alignment 'center 'center) (set-alignment 'center 'center)
(stretchable-height #f)) (stretchable-height #f))

153
collects/framework/private/standard-menus-items.ss
View File

@ -1,4 +1,5 @@
(module standard-menus-items mzscheme (module standard-menus-items mzscheme
(provide (provide
(struct generic (name initializer)) (struct generic (name initializer))
@ -179,7 +180,8 @@
'file-menu 'file-menu
'(make-object (get-menu%) '(make-object (get-menu%)
(if (eq? (system-type) 'windows) (if (eq? (system-type) 'windows)
"&File" "F&ile") (string-constant file-menu-label-windows)
(string-constant file-menu-label-other))
(get-menu-bar))) (get-menu-bar)))
(make-generic-method (make-generic-method
'get-edit-menu 'get-edit-menu
@ -190,7 +192,9 @@
"@ilink frame:standard-menus get-menu\\%" "@ilink frame:standard-menus get-menu\\%"
"" ""
"@return : (instance (derived-from \\iscmclass{menu}))")) "@return : (instance (derived-from \\iscmclass{menu}))"))
(make-generic-private-field 'edit-menu '(make-object (get-menu%) "&Edit" (get-menu-bar))) (make-generic-private-field
'edit-menu
'(make-object (get-menu%) (string-constant edit-menu-label) (get-menu-bar)))
(make-generic-method (make-generic-method
'get-help-menu 'get-help-menu
'(lambda () help-menu) '(lambda () help-menu)
@ -202,112 +206,165 @@
"@return : (instance (derived-from \\iscmclass{menu}))")) "@return : (instance (derived-from \\iscmclass{menu}))"))
(make-generic-private-field (make-generic-private-field
'help-menu 'help-menu
'(make-object (get-menu%) "&Help" (get-menu-bar))) '(make-object (get-menu%) (string-constant help-menu-label) (get-menu-bar)))
(make-an-item 'file-menu 'new "Open a new file" (make-an-item 'file-menu 'new
'(string-constant new-info)
'(lambda (item control) (handler:edit-file #f) #t) '(lambda (item control) (handler:edit-file #f) #t)
#\n "&New" "" #\n
'(string-constant new-menu-item-before)
'(string-constant new-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-between 'file-menu 'new 'open 'nothing) (make-between 'file-menu 'new 'open 'nothing)
(make-an-item 'file-menu 'open "Open a file from disk" (make-an-item 'file-menu 'open '(string-constant open-info)
'(lambda (item control) (handler:open-file) #t) '(lambda (item control) (handler:open-file) #t)
#\o "&Open" "..." #\o
'(string-constant open-menu-item-before)
'(string-constant open-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-between 'file-menu 'open 'revert 'nothing) (make-between 'file-menu 'open 'revert 'nothing)
(make-an-item 'file-menu 'revert (make-an-item 'file-menu 'revert
"Revert this file to the copy on disk" '(string-constant revert-info)
#f #f "&Revert" "" #f #f
'(string-constant revert-menu-item-before)
'(string-constant revert-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-between 'file-menu 'revert 'save 'nothing) (make-between 'file-menu 'revert 'save 'nothing)
(make-an-item 'file-menu 'save (make-an-item 'file-menu 'save
"Save this file to disk" '(string-constant save-info)
#f #\s "&Save" "" #f #\s
'(string-constant save-menu-item-before)
'(string-constant save-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-an-item 'file-menu 'save-as (make-an-item 'file-menu 'save-as
"Prompt for a filename and save this file to disk" '(string-constant save-as-info)
#f #f "Save" " &As..." #f #f
'(string-constant save-as-menu-item-before)
'(string-constant save-as-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-between 'file-menu 'save-as 'print 'separator) (make-between 'file-menu 'save-as 'print 'separator)
(make-an-item 'file-menu 'print (make-an-item 'file-menu 'print
"Print this file" '(string-constant print-info)
#f #\p "&Print" "..." #f #\p
'(string-constant print-menu-item-before)
'(string-constant print-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-between 'file-menu 'print 'close 'separator) (make-between 'file-menu 'print 'close 'separator)
(make-an-item 'file-menu 'close (make-an-item 'file-menu 'close
"Close this file" '(string-constant close-info)
'(lambda (item control) (when (can-close?) (on-close) (show #f)) #t) '(lambda (item control) (when (can-close?) (on-close) (show #f)) #t)
#\w "&Close" "" #\w
'(string-constant close-menu-item-before)
'(string-constant close-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-between 'file-menu 'close 'quit 'nothing) (make-between 'file-menu 'close 'quit 'nothing)
(make-an-item 'file-menu 'quit (make-an-item 'file-menu 'quit
"Quit" '(string-constant quit-info)
'(lambda (item control) (parameterize ([exit:frame-exiting this]) (exit:exit))) '(lambda (item control)
(parameterize ([exit:frame-exiting this])
(exit:exit)))
#\q #\q
'(if (eq? (system-type) 'windows) "E&xit" "Quit") '(if (eq? (system-type) 'windows)
"" (string-constant quit-menu-item-before-windows)
(string-constant quit-menu-item-before-others))
'(string-constant quit-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-after 'file-menu 'quit 'nothing) (make-after 'file-menu 'quit 'nothing)
(make-an-item 'edit-menu 'undo "Undo the most recent action" (make-an-item 'edit-menu 'undo
'(string-constant undo-info)
(edit-menu:do 'undo) (edit-menu:do 'undo)
#\z "&Undo" "" #\z
'(string-constant undo-menu-item)
""
(edit-menu:can-do-on-demand 'undo)) (edit-menu:can-do-on-demand 'undo))
(make-an-item 'edit-menu 'redo "Redo the most recent undo" (make-an-item 'edit-menu 'redo
'(string-constant redo-info)
(edit-menu:do 'redo) (edit-menu:do 'redo)
#\y "&Redo" "" #\y
'(string-constant redo-menu-item)
""
(edit-menu:can-do-on-demand 'redo)) (edit-menu:can-do-on-demand 'redo))
(make-between 'edit-menu 'redo 'cut 'separator) (make-between 'edit-menu 'redo 'cut 'separator)
(make-an-item 'edit-menu 'cut "Cut the selection" (make-an-item 'edit-menu 'cut '(string-constant cut-info)
(edit-menu:do 'cut) (edit-menu:do 'cut)
#\x "Cu&t" "" #\x
'(string-constant cut-menu-item)
""
(edit-menu:can-do-on-demand 'cut)) (edit-menu:can-do-on-demand 'cut))
(make-between 'edit-menu 'cut 'copy 'nothing) (make-between 'edit-menu 'cut 'copy 'nothing)
(make-an-item 'edit-menu 'copy "Copy the selection" (make-an-item 'edit-menu 'copy
'(string-constant copy-info)
(edit-menu:do 'copy) (edit-menu:do 'copy)
#\c "&Copy" "" #\c
'(string-constant copy-menu-item)
""
(edit-menu:can-do-on-demand 'copy)) (edit-menu:can-do-on-demand 'copy))
(make-between 'edit-menu 'copy 'paste 'nothing) (make-between 'edit-menu 'copy 'paste 'nothing)
(make-an-item 'edit-menu 'paste "Paste the most recent copy or cut over the selection" (make-an-item 'edit-menu 'paste
'(string-constant paste-info)
(edit-menu:do 'paste) (edit-menu:do 'paste)
#\v "&Paste" "" #\v
'(string-constant paste-menu-item)
""
(edit-menu:can-do-on-demand 'paste)) (edit-menu:can-do-on-demand 'paste))
(make-between 'edit-menu 'paste 'clear 'nothing) (make-between 'edit-menu 'paste 'clear 'nothing)
(make-an-item 'edit-menu 'clear "Clear the selection without affecting paste" (make-an-item 'edit-menu 'clear
'(string-constant clear-info)
(edit-menu:do 'clear) (edit-menu:do 'clear)
#f #f
'(if (eq? (system-type) 'macos) '(if (eq? (system-type) 'windows)
"Clear" (string-constant clear-menu-item-windows)
"&Delete") (string-constant clear-menu-item-windows))
"" ""
(edit-menu:can-do-on-demand 'clear)) (edit-menu:can-do-on-demand 'clear))
(make-between 'edit-menu 'clear 'select-all 'nothing) (make-between 'edit-menu 'clear 'select-all 'nothing)
(make-an-item 'edit-menu 'select-all "Select the entire document" (make-an-item 'edit-menu 'select-all
'(string-constant select-all-info)
(edit-menu:do 'select-all) (edit-menu:do 'select-all)
#\a "Select A&ll" "" #\a
'(string-constant select-all-menu-item)
""
(edit-menu:can-do-on-demand 'select-all)) (edit-menu:can-do-on-demand 'select-all))
(make-between 'edit-menu 'select-all 'find 'separator) (make-between 'edit-menu 'select-all 'find 'separator)
(make-an-item 'edit-menu 'find "Search for a string in the window" #f
#\f "Find" "..." (make-an-item 'edit-menu 'find
'(string-constant find-info)
#f
#\f
'(string-constant find-menu-item-before)
'(string-constant find-menu-item-after)
edit-menu:edit-target-on-demand) edit-menu:edit-target-on-demand)
(make-an-item 'edit-menu 'find-again "Search for the same string as before" #f (make-an-item 'edit-menu 'find-again
#\g "Find Again" "" '(string-constant find-again-info)
#f
#\g
'(string-constant find-menu-item-before)
'(string-constant find-menu-item-after)
edit-menu:edit-target-on-demand) edit-menu:edit-target-on-demand)
(make-an-item 'edit-menu 'replace-and-find-again (make-an-item 'edit-menu 'replace-and-find-again
"Replace the current text and search for the same string as before" '(string-constant replace-and-find-again-info)
#f #\h "Replace && Find Again" "" #f #\h
'(string-constant replace-and-find-again-menu-item-before)
'(string-constant replace-and-find-again-menu-item-after)
edit-menu:edit-target-on-demand) edit-menu:edit-target-on-demand)
(make-between 'edit-menu 'find 'preferences 'separator) (make-between 'edit-menu 'find 'preferences 'separator)
(make-an-item 'edit-menu 'preferences "Configure the preferences" (make-an-item 'edit-menu 'preferences
'(string-constant preferences-info)
'(lambda (item control) (preferences:show-dialog) #t) '(lambda (item control) (preferences:show-dialog) #t)
#\; "Preferences..." "" #\;
'(string-constant preferences-menu-item-before)
'(string-constant preferences-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-after 'edit-menu 'preferences 'nothing) (make-after 'edit-menu 'preferences 'nothing)
(make-before 'help-menu 'about 'nothing) (make-before 'help-menu 'about 'nothing)
(make-an-item 'help-menu 'about "Credits and details for this application" (make-an-item 'help-menu 'about
'(string-constant about-info)
#f #f
#f #f
"About " '(string-constant about-menu-item-before)
"..." '(string-constant about-menu-item-after)
on-demand-do-nothing) on-demand-do-nothing)
(make-after 'help-menu 'about 'nothing)))) (make-after 'help-menu 'about 'nothing))))

11
collects/framework/private/text.ss
View File

@ -1,5 +1,6 @@
(module text mzscheme (module text mzscheme
(require (lib "unitsig.ss") (require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
"sig.ss" "sig.ss"
@ -446,14 +447,18 @@
(eq? 'standard (get-file-format)) (eq? 'standard (get-file-format))
(or (not (preferences:get 'framework:verify-change-format)) (or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice (gui-utils:get-choice
"Save this file as plain text?" "Yes" "No"))) (string-constant save-as-plain-text)
(string-constant yes)
(string-constant no))))
(set-file-format 'text)] (set-file-format 'text)]
[(and (not all-strings?) [(and (not all-strings?)
(or (eq? format 'same) (eq? format 'copy)) (or (eq? format 'same) (eq? format 'copy))
(eq? 'text (get-file-format)) (eq? 'text (get-file-format))
(or (not (preferences:get 'framework:verify-change-format)) (or (not (preferences:get 'framework:verify-change-format))
(gui-utils:get-choice (gui-utils:get-choice
"Save this file in drscheme-specific non-text format?" "Yes" "No"))) (string-constant save-in-drs-format)
(string-constant yes)
(string-constant no))))
(set-file-format 'standard)] (set-file-format 'standard)]
[else (void)])) [else (void)]))
(super-on-save-file name format)) (super-on-save-file name format))