From 73fbf3b9fb247e358cb9a31404a165d757eab32b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 21 May 2002 16:37:32 +0000 Subject: [PATCH] .. original commit: 3b75abebfbf22483d3c12c253fa9dcedf617a9f8 --- collects/framework/framework.ss | 45 +++++- collects/framework/private/frame.ss | 7 +- collects/framework/private/panel.ss | 82 +++++----- collects/framework/private/preferences.ss | 188 +++++++++++++++------- collects/framework/private/sig.ss | 14 +- 5 files changed, 235 insertions(+), 101 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index b7c085dd..c055247f 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -182,6 +182,7 @@ () "\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the" "default preferences.") + (preferences:add-panel (string? ((is-a?/c area-container-window<%>) . -> . (is-a?/c area-container-window<%>)) @@ -195,14 +196,50 @@ "\\var{f} is expected to add a new child panel to it and add" "whatever preferences configuration controls it wants to that" "panel. Then, \\var{f}'s should return the panel it added.") + + (preferences:add-editor-checkbox-panel + (-> void?) + () + "Adds a preferences panel for configuring options" + "related to editing.") + (preferences:add-misc-checkbox-panel + (-> void?) + () + "Adds a preferences panel for configuring" + "misc. options") + (preferences:add-scheme-checkbox-panel + (-> void?) + () + "Adds a preferences panel for configuring" + "options related to Scheme.") + + (preferences:add-to-misc-checkbox-panel + (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) + (proc) + "Saves \\var{proc} until the preferences panel is" + "created, when it is called with the Misc. panel to" + "add new children to the panel.") + + (preferences:add-to-scheme-checkbox-panel + (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) + (proc) + "Saves \\var{proc} until the preferences panel is " + "created, when it is called with the Scheme " + "preferences panel to " + "add new children to the panel.") + + (preferences:add-to-editor-checkbox-panel + (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) + (proc) + "Saves \\var{proc} until the preferences panel is " + "created, when it is called with the Echeme " + "preferences panel to " + "add new children to the panel.") + (preferences:add-font-panel (-> void?) () "Adds a font selection preferences panel to the preferences dialog.") - (preferences:add-general-panel - (-> void?) - () - "Adds a general preferences panel to the preferences dialog.") (preferences:show-dialog (-> void?) () diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 05b0b61c..41b85f31 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1703,8 +1703,11 @@ (send find-edit get-text 0 (send find-edit last-position))))))) (define replace&search (lambda () - (when (replace) - (search-again)))) + (let ([text (get-text-to-search)]) + (send text begin-edit-sequence) + (when (replace) + (search-again)) + (send text end-edit-sequence)))) (define replace-all (lambda () (let* ([replacee-edit (get-text-to-search)] diff --git a/collects/framework/private/panel.ss b/collects/framework/private/panel.ss index a57d39c7..5066875b 100644 --- a/collects/framework/private/panel.ss +++ b/collects/framework/private/panel.ss @@ -189,27 +189,41 @@ ;; type percentage : (make-percentage number) (define-struct percentage (%)) + (define dragable<%> + (interface () + after-percentage-change + set-percentages + get-percentages + get-vertical?)) + (define vertical-dragable<%> - (interface ((class->interface vertical-panel%)) - after-percentage-change - set-percentages - get-percentages)) - + (interface (dragable<%>))) + (define horizontal-dragable<%> - (interface ((class->interface horizontal-panel%)) - after-percentage-change - set-percentages - get-percentages)) + (interface (dragable<%>))) - (define (make-dragable-mixin vertical? - panel% dragable<%> - min-extent - event-get-dim - get-cursor) + (define dragable-mixin (mixin ((class->interface panel%)) (dragable<%>) - (init parent) - (super-instantiate (parent)) - (inherit get-client-size container-flow-modified) + (init parent) + + (define/public (get-vertical?) + (error 'get-vertical "abstract method")) + (define/private (min-extent child) + (if (get-vertical?) + (send child min-height) + (send child min-width))) + (define/private (event-get-dim evt) + (if (get-vertical?) + (send evt get-y) + (send evt get-x))) + (define/private (get-gap-cursor) + (if (get-vertical?) + (icon:get-up/down-cursor) + (icon:get-left/right-cursor))) + + (super-instantiate (parent)) + + (inherit get-client-size container-flow-modified) (init-field [bar-thickness 5]) @@ -250,7 +264,7 @@ (define/private (get-available-extent) (let-values ([(width height) (get-client-size)]) - (- (if vertical? height width) + (- (if (get-vertical?) height width) (* bar-thickness (- (length (get-children)) 1))))) (inherit get-children) @@ -282,7 +296,7 @@ (set-cursor (and (or gap resizing-dim) (send (icon:get-up/down-cursor) ok?) - (get-cursor))) + (get-gap-cursor))) (cond [(and gap (send evt button-down? 'left)) (set! resizing-dim (event-get-dim evt)) @@ -338,7 +352,7 @@ (when (null? children) (show-error 4)) (unless (null? (cdr infos)) (show-error 5)) (unless (null? (cdr children)) (show-error 6)) - (if vertical? + (if (get-vertical?) (list (list 0 dim width (- height dim))) (list (list dim 0 (- width dim) height)))] [else @@ -356,7 +370,7 @@ (+ dim this-space bar-thickness) (cadr percentages)) cursor-gaps)) - (cons (if vertical? + (cons (if (get-vertical?) (list 0 dim width this-space) (list dim 0 this-space height)) (loop (cdr percentages) @@ -365,21 +379,17 @@ (+ dim this-space bar-thickness))))])))])))) - (define vertical-dragable-mixin - (make-dragable-mixin #t - vertical-panel% vertical-dragable<%> - (lambda (child) (send child min-height)) - (lambda (evt) (send evt get-y)) - icon:get-up/down-cursor)) - - (define horizontal-dragable-mixin - (make-dragable-mixin #f - horizontal-panel% horizontal-dragable<%> - (lambda (child) (send child min-width)) - (lambda (evt) (send evt get-x)) - icon:get-left/right-cursor)) + (define vertical-dragable-mixin + (mixin (dragable<%>) (vertical-dragable<%>) + (define/override (get-vertical?) #t) + (super-instantiate ()))) + + (define horizontal-dragable-mixin + (mixin (dragable<%>) (vertical-dragable<%>) + (define/override (get-vertical?) #f) + (super-instantiate ()))) - (define vertical-dragable% (vertical-dragable-mixin vertical-panel%)) + (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%))) - (define horizontal-dragable% (horizontal-dragable-mixin horizontal-panel%))))) + (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%)))))) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 9b5a3b9d..ea6566a8 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -331,69 +331,141 @@ (define ppanels null) - (define (local-add-general-panel) + (define (add-to-scheme-checkbox-panel f) + (set! scheme-panel-procs + (let ([old scheme-panel-procs]) + (lambda (parent) (old parent) (f parent))))) + + (define (add-to-editor-checkbox-panel f) + (set! editor-panel-procs + (let ([old editor-panel-procs]) + (lambda (parent) (old parent) (f parent))))) + + (define (add-to-misc-checkbox-panel f) + (set! misc-panel-procs + (let ([old misc-panel-procs]) + (lambda (parent) (old parent) (f parent))))) + + (define scheme-panel-procs void) + (define editor-panel-procs void) + (define misc-panel-procs void) + + (define (add-checkbox-panel label proc) (add-panel - (string-constant general-prefs-panel-label) + label (lambda (parent) - (let* ([main (make-object vertical-panel% parent)] - [make-check - (lambda (pref title bool->pref pref->bool) - (let* ([callback - (lambda (check-box _) - (set pref (bool->pref (send check-box get-value))))] - [pref-value (get pref)] - [initial-value (pref->bool pref-value)] - [c (make-object check-box% title main callback)]) - (send c set-value initial-value) - (add-callback pref - (lambda (p v) - (send c set-value (pref->bool v))))))] - [id (lambda (x) x)]) + (let* ([main (make-object vertical-panel% parent)]) (send main set-alignment 'left 'center) - (make-check 'framework:highlight-parens (string-constant highlight-parens) id id) - (make-check 'framework:fixup-parens (string-constant fixup-parens) id id) - (make-check 'framework:paren-match (string-constant flash-paren-match) id id) - (make-check 'framework:autosaving-on? (string-constant auto-save-files) id id) - (make-check 'framework:backup-files? (string-constant backup-files) id id) - (make-check 'framework:delete-forward? (string-constant map-delete-to-backspace) - not not) - - (make-check 'framework:verify-exit (string-constant verify-exit) id id) - (make-check 'framework:verify-change-format - (string-constant ask-before-changing-format) - id id) - (make-check 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers) - id id) - - (make-check 'framework:show-status-line (string-constant show-status-line) id id) - (make-check 'framework:line-offsets (string-constant count-from-one) id id) - (make-check 'framework:display-line-numbers - (string-constant display-line-numbers) - id id) - (make-check 'framework:menu-bindings (string-constant enable-keybindings-in-menus) - id id) - (unless (eq? (system-type) 'unix) - (make-check 'framework:print-output-mode - (string-constant automatically-to-ps) - (lambda (b) - (if b 'postscript 'standard)) - (lambda (n) (eq? 'postscript n)))) - - - '(when (eq? (system-type) 'windows) - (make-check 'framework:windows-mdi (string-constant use-mdi) id id)) - (make-check 'framework:search-using-dialog? - (string-constant separate-dialog-for-searching) - id id) - (make-check 'framework:open-here? - (string-constant reuse-existing-frames) - id id) - - main))) - (set! local-add-general-panel void)) + (proc main) + main)))) - (define (add-general-panel) (local-add-general-panel)) + ;; make-check : panel symbol string (boolean -> any) (any -> boolean) + ;; adds a check box preference to `main'. + (define (make-check main pref title bool->pref pref->bool) + (let* ([callback + (lambda (check-box _) + (set pref (bool->pref (send check-box get-value))))] + [pref-value (get pref)] + [initial-value (pref->bool pref-value)] + [c (make-object check-box% title main callback)]) + (send c set-value initial-value) + (add-callback pref + (lambda (p v) + (send c set-value (pref->bool v)))))) + + (define (add-scheme-checkbox-panel) + (letrec ([add-scheme-checkbox-panel + (lambda () + (set! add-scheme-checkbox-panel void) + (add-checkbox-panel + (string-constant scheme-prefs-panel-label) + (lambda (scheme-panel) + (make-check scheme-panel + 'framework:highlight-parens + (string-constant highlight-parens) + values values) + (make-check scheme-panel + 'framework:fixup-parens + (string-constant fixup-parens) + values values) + (make-check scheme-panel + 'framework:paren-match + (string-constant flash-paren-match) + values values) + (scheme-panel-procs scheme-panel))))]) + (add-scheme-checkbox-panel))) + (define (add-editor-checkbox-panel) + (letrec ([add-editor-checkbox-panel + (lambda () + (set! add-editor-checkbox-panel void) + (add-checkbox-panel + (string-constant editor-prefs-panel-label) + (lambda (editor-panel) + (make-check editor-panel + 'framework:autosaving-on? + (string-constant auto-save-files) + values values) + (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) + (make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace) + not not) + + (make-check editor-panel + 'framework:verify-change-format + (string-constant ask-before-changing-format) + values values) + (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) + (make-check editor-panel 'framework:line-offsets (string-constant count-from-one) values values) + (make-check editor-panel + 'framework:display-line-numbers + (string-constant display-line-numbers) + values values) + + (make-check editor-panel + 'framework:auto-set-wrap? + (string-constant wrap-words-in-editor-buffers) + values values) + (make-check editor-panel + 'framework:search-using-dialog? + (string-constant separate-dialog-for-searching) + values values) + (make-check editor-panel + 'framework:open-here? + (string-constant reuse-existing-frames) + values values) + (editor-panel-procs editor-panel))))]) + (add-editor-checkbox-panel))) + + (define (add-misc-checkbox-panel) + (letrec ([add-misc-checkbox-panel + (lambda () + (set! add-misc-checkbox-panel void) + (add-checkbox-panel + (string-constant misc-prefs-panel-label) + (lambda (misc-panel) + (make-check misc-panel + 'framework:verify-exit + (string-constant verify-exit) + values values) + (make-check misc-panel + 'framework:menu-bindings + (string-constant enable-keybindings-in-menus) + values values) + (unless (eq? (system-type) 'unix) + (make-check misc-panel + 'framework:print-output-mode + (string-constant automatically-to-ps) + (lambda (b) + (if b 'postscript 'standard)) + (lambda (n) (eq? 'postscript n)))) + '(when (eq? (system-type) 'windows) + (make-check misc-panel + 'framework:windows-mdi + (string-constant use-mdi) + values values)) + (misc-panel-procs misc-panel))))]) + (add-misc-checkbox-panel))) + (define (local-add-font-panel) (let* ([font-families-name/const (list (list "Default" 'default) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 6d69060b..992b979a 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -116,9 +116,13 @@ single-pane% ;;multi-view% + dragable<%> + dragable-mixin + vertical-dragable<%> vertical-dragable-mixin vertical-dragable% + horizontal-dragable<%> horizontal-dragable-mixin horizontal-dragable%)) @@ -160,7 +164,15 @@ add-panel add-font-panel - add-general-panel + + add-editor-checkbox-panel + add-misc-checkbox-panel + add-scheme-checkbox-panel + + add-to-editor-checkbox-panel + add-to-misc-checkbox-panel + add-to-scheme-checkbox-panel + show-dialog hide-dialog)) (define-signature framework:preferences^