diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 8ea37718..af95dda1 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -47,7 +47,7 @@ "on the number." "" "See also" - "@flink number-snip:number-snip:make-fraction-snip %" + "@flink number-snip:make-fraction-snip %" ".") (number-snip:make-fraction-snip (number? boolean? . -> . (is-a?/c snip%)) @@ -58,7 +58,7 @@ "on the number, when shown in the decimal state." "" "See also" - "@flink drscheme:number-snip:make-repeating-decimal-snip %" + "@flink number-snip:make-repeating-decimal-snip %" ".") (version:add-spec (any? any? . -> . void?) @@ -229,7 +229,7 @@ "default preferences.") (preferences:add-panel - ((union string? (cons/p string? (listof string?))) + ((union string? (cons/c string? (listof string?))) ((is-a?/c area-container-window<%>) . ->d . (lambda (parent) @@ -479,8 +479,8 @@ "Its default value is \\rawscm{\"\"}.") (finder:default-filters (case-> - ((listof (list/p string? string?)) . -> . void?) - (-> (listof (list/p string? string?)))) + ((listof (list/c string? string?)) . -> . void?) + (-> (listof (list/c string? string?)))) ((filters) ()) "This parameter controls the default extension for the framework's " "@flink finder:put-file" @@ -1296,7 +1296,7 @@ "section.") (scheme:get-color-prefs-table - (-> (listof (list/p symbol? (is-a?/c color%)))) + (-> (listof (list/c symbol? (is-a?/c color%)))) () "Returns a table mapping from symbols (naming the categories that" "the online colorer uses for Scheme mode coloring) to their" @@ -1390,7 +1390,7 @@ "red green and blue for the second color, respectively.") (color-model:xyz->rgb - (number? number? number? . -> . (list/p number? number? number?)) + (number? number? number? . -> . (list/c number? number? number?)) (x y z) "Converts an XYZ-tuple (in the CIE XYZ colorspace) into a list of" "values representing an RGB-tuple.") @@ -1437,10 +1437,13 @@ "to set a callback for \\var{pref-name} that" "updates the style list when the preference changes.") - (color-prefs:add-preferences-panel + (color-prefs:add-background-preferences-panel (-> void?) () - "Adds in a preferences panel that configures colors (typically of text)") + "Adds a preferences panel that configures the background" + "color for" + "@mixin-link editor:basic-mixin %" + ".") (color-prefs:add-to-preferences-panel (string? ((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (name func) diff --git a/collects/framework/private/canvas.ss b/collects/framework/private/canvas.ss index cde23a5f..0b27f014 100644 --- a/collects/framework/private/canvas.ss +++ b/collects/framework/private/canvas.ss @@ -16,7 +16,11 @@ (define basic<%> (interface ((class->interface editor-canvas%)))) (define basic-mixin (mixin ((class->interface editor-canvas%)) (basic<%>) - (super-instantiate ()))) + (super-new) + (define callback (lambda (p v) (set-canvas-background v))) + (inherit set-canvas-background) + (set-canvas-background (preferences:get 'framework:basic-canvas-background)) + (preferences:add-callback 'framework:basic-canvas-background callback #t))) (define delegate<%> (interface (basic<%>))) diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 4212a920..242a9c06 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -9,14 +9,14 @@ (provide color-prefs@) (define sc-color-syntax-interactively (string-constant color-syntax-interactively)) - (define sc-syntax-coloring (string-constant syntax-coloring)) (define sc-choose-color (string-constant syntax-coloring-choose-color)) (define color-prefs@ (unit/sig framework:color-prefs^ (import [preferences : framework:preferences^] [editor : framework:editor^] - [panel : framework:panel^]) + [panel : framework:panel^] + [canvas : framework:canvas^]) (define standard-style-list-text% (editor:standard-style-list-mixin text%)) @@ -37,7 +37,7 @@ style-name)]) (change-style style pos (+ pos offset) #f))) (super-new)))) - (define c (new editor-canvas% + (define c (new canvas:basic% (parent hp) (editor e) (style '(hide-hscroll @@ -188,87 +188,51 @@ (send sd set-style-off 'italic))) sd)) - - ;; prefs-panel-mapping : (union #f - ;; hash-table[symbol -o> (is-a?/c vertical-panel)]) - ;; #f => prefs panel not yet opened - ;; hash-table => prefs panel opened - ;; the table maps from the name of the color preference to - ;; the corresponding subpanel - (define prefs-panel-mapping #f) - - ;; prefs-panel-todo : (union #f (listof (cons string (vertical-panel -> void)))) - ;; list => prefs panel not opened yet - ;; #f => prefs panel already opened. - (define prefs-panel-todo '()) - - ;; prefs-panel-tab-panel : (union #f tab-panel) - (define prefs-panel-tab-panel #f) - ;; prefs-panel-single : (union #f single-panel%)) - (define prefs-panel-single #f) - - (define prefs-panel-children '()) - - ;; update-panel-single : -> void - ;; callback for the prefs-panel-tab-panel - (define (update-panel-single) - (let ([sel (send prefs-panel-tab-panel get-selection)]) - (when sel - (let* ([label (list-ref prefs-panel-children sel)] - [panel (hash-table-get prefs-panel-mapping (string->symbol label))]) - (send prefs-panel-single active-child panel))))) - - ;; add-preferences-panel : -> void - ;; calls preferences:add-panel to add the coloring configuration panels - (define (add-preferences-panel) + (define (add-background-preferences-panel) (preferences:add-panel - (list sc-syntax-coloring) + (list (string-constant preferences-colors) + (string-constant background-color)) (lambda (parent) - (set! prefs-panel-tab-panel (new tab-panel% - (parent parent) - (choices (map car prefs-panel-todo)) - (callback (lambda (x y) (update-panel-single))))) - (set! prefs-panel-single (new panel:single% (parent prefs-panel-tab-panel))) - (set! prefs-panel-mapping (make-hash-table)) - (for-each - (lambda (pr) - (let* ([name (car pr)] - [proc (cdr pr)] - [panel (build-new-prefs-panel name)]) - (proc panel))) - prefs-panel-todo) - (set! prefs-panel-todo #f) - prefs-panel-tab-panel))) + (letrec ([panel (new vertical-panel% (parent parent))] + [hp (new horizontal-panel% (parent panel))] + [canvas + (new canvas% + (parent hp) + (paint-callback + (lambda (c dc) + (draw (preferences:get 'framework:basic-canvas-background)))))] + [draw + (lambda (clr) + (let ([dc (send canvas get-dc)]) + (let-values ([(w h) (send canvas get-client-size)]) + (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid)) + (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid)) + (send dc draw-rectangle 0 0 w h))))] + [button + (new button% + (label (string-constant cs-change-color)) + (parent hp) + (callback + (lambda (x y) + (let ([color (get-color-from-user + (string-constant choose-a-background-color) + (send hp get-top-level-window) + (preferences:get 'framework:basic-canvas-background))]) + (when color + (preferences:set 'framework:basic-canvas-background color))))))]) + (preferences:add-callback + 'framework:basic-canvas-background + (lambda (p v) (draw v))) + panel)))) ;; add-to-preferences-panel : string (vertical-panel -> void) -> void (define (add-to-preferences-panel panel-name func) - (let ([key (string->symbol panel-name)]) - (cond - [prefs-panel-todo - (let ([prev-pr (assq key prefs-panel-todo)]) - (if prev-pr - (let ([proc (cdr prev-pr)]) - (set-cdr! prev-pr - (lambda (parent) - (proc parent) - (func parent)))) - (set! prefs-panel-todo - (append prefs-panel-todo (list (cons panel-name func))))))] - [else - (let ([prev-panel (hash-table-get prefs-panel-mapping key (lambda () #f))]) - (cond - [prev-panel (func prev-panel)] - [else - (send prefs-panel-tab-panel append panel-name) - (let ([new-panel (build-new-prefs-panel panel-name)]) - (func new-panel))]))]))) - - ;; build-new-prefs-panel : string -> horizontal-panel - (define (build-new-prefs-panel name) - (let ([panel (new vertical-panel% (parent prefs-panel-single))]) - (set! prefs-panel-children (append prefs-panel-children (list name))) - (hash-table-put! prefs-panel-mapping (string->symbol name) panel) - panel)) + (preferences:add-panel + (list (string-constant preferences-colors) panel-name) + (lambda (parent) + (let ([panel (new vertical-panel% (parent parent))]) + (func panel) + panel)))) ;; see docs (define (register-color-pref pref-name style-name color) diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 82fb6d69..87652a13 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -47,7 +47,7 @@ (define basic-mixin (mixin (editor<%>) (basic<%>) - (define/public (can-close?) #t) + (define/pubment (can-close?) (inner #t can-close?)) (define/pubment (on-close) (inner (void) on-close)) (define/public (close) (if (can-close?) (begin (on-close) #t) @@ -386,33 +386,16 @@ (define file<%> (interface (-keymap<%>) - get-read-write? get-filename/untitled-name get-can-close-parent update-frame-filename)) (define file-mixin (mixin (-keymap<%>) (file<%>) - (inherit - get-filename lock get-style-list - is-modified? set-modified - get-top-level-window) + (inherit get-filename lock get-style-list + is-modified? set-modified + get-top-level-window) (inherit get-canvases) - (define read-write? #t) - (define/public (get-read-write?) read-write?) - (define/private (check-lock) - (let* ([filename (get-filename)] - [can-edit? (if (and filename - (file-exists? filename)) - (and (member 'write (file-or-directory-permissions filename)) - #t) - #t)]) - (set! read-write? can-edit?))) - - (define/augment (can-insert? x y) - (and read-write? (inner #t can-insert? x y))) - (define/augment (can-delete? x y) (and read-write? (inner #t can-delete? x y))) - (define/public (update-frame-filename) (let* ([filename (get-filename)] [name (if filename @@ -437,15 +420,6 @@ (unless untitled-name (set! untitled-name (gui-utils:next-untitled-name))) untitled-name)))) - (define/augment (after-save-file success) - (when success - (check-lock)) - (inner (void) after-save-file success)) - - (define/augment (after-load-file sucessful?) - (when sucessful? - (check-lock)) - (inner (void) after-load-file sucessful?)) (define/override set-filename (case-lambda @@ -456,7 +430,7 @@ (update-frame-filename))])) (inherit save-file) - (define/override (can-close?) + (define/augment (can-close?) (let* ([user-allowed-or-not-modified (or (not (is-modified?)) (case (gui-utils:unsaved-warning @@ -469,7 +443,7 @@ [(save) (save-file)] [else #f]))]) (and user-allowed-or-not-modified - (super can-close?)))) + (inner #t can-close?)))) (define/public (get-can-close-parent) #f) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 242438e1..50277eb0 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -546,16 +546,15 @@ 'framework:show-status-line (lambda (p v) (update-info-visibility v)))] - [define memory-cleanup void] ;; only for CVSers and nightly build users; used with memory-text + (define memory-cleanup void) ;; only for CVSers and nightly build users; used with memory-text - [define/augment on-close - (lambda () - (unregister-collecting-blit gc-canvas) - (close-panel-callback) - (memory-cleanup) - (inner (void) on-close))] + (define/augment (on-close) + (unregister-collecting-blit gc-canvas) + (close-panel-callback) + (memory-cleanup) + (inner (void) on-close)) - [define icon-currently-locked? 'uninit] + (define icon-currently-locked? 'uninit) (define/public (lock-status-changed) (let ([info-edit (get-info-editor)]) (cond diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 29eeb634..a12930ec 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -22,6 +22,18 @@ (application-preferences-handler (lambda () (preferences:show-dialog))) + (preferences:set-default 'framework:basic-canvas-background + (send the-color-database find-color "pink") + (lambda (x) (is-a? x color%))) + (preferences:set-un/marshall + 'framework:basic-canvas-background + (lambda (clr) (list (send clr red) (send clr green) (send clr blue))) + (lambda (lst) (and (pair? lst) + (pair? (cdr lst)) + (pair? (cddr lst)) + (null? (cdddr lst)) + (make-object color% (car lst) (cadr lst) (caddr lst))))) + (preferences:set-default 'framework:special-option-key #f boolean?) (preferences:add-callback 'framework:special-option-key (lambda (p v) (special-option-key v))) (special-option-key (preferences:get 'framework:special-option-key)) diff --git a/collects/framework/private/menu.ss b/collects/framework/private/menu.ss index 4c0fbb55..5949937c 100644 --- a/collects/framework/private/menu.ss +++ b/collects/framework/private/menu.ss @@ -19,11 +19,10 @@ (define can-restore-mixin (mixin (selectable-menu-item<%>) (can-restore<%>) (inherit set-shortcut get-shortcut) - [define saved-shortcut 'not-yet] - [define/public restore-keybinding - (lambda () - (unless (eq? saved-shortcut 'not-yet) - (set-shortcut saved-shortcut)))] + (define saved-shortcut 'not-yet) + (define/public (restore-keybinding) + (unless (eq? saved-shortcut 'not-yet) + (set-shortcut saved-shortcut))) (super-instantiate ()) (set! saved-shortcut (get-shortcut)) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 8b128737..d6763b58 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -300,6 +300,7 @@ searching<%> return<%> info<%> + file<%> clever-file-format<%> ports<%> @@ -326,6 +327,7 @@ searching-mixin return-mixin info-mixin + file-mixin clever-file-format-mixin ports-mixin)) (define-signature framework:text-fun^ @@ -502,8 +504,8 @@ (define-signature framework:color-prefs-fun^ (register-color-pref add-to-preferences-panel - add-preferences-panel - build-color-selection-panel)) + build-color-selection-panel + add-background-preferences-panel)) (define-signature framework:color-prefs^ ((open framework:color-prefs-class^) (open framework:color-prefs-fun^))) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 6626a751..bf338638 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -815,6 +815,42 @@ WARNING: printf is rebound in the body of the unit to always (inner (void) on-save-file name format)) (super-instantiate ()))) + + (define file<%> + (interface (editor:file<%> basic<%>) + get-read-write?)) + + (define file-mixin + (mixin (editor:file<%> basic<%>) (file<%>) + (inherit get-filename) + (define read-write? #t) + (define/public (get-read-write?) read-write?) + (define/private (check-lock) + (let* ([filename (get-filename)] + [can-edit? (if (and filename + (file-exists? filename)) + (and (member 'write (file-or-directory-permissions filename)) + #t) + #t)]) + (set! read-write? can-edit?))) + + (define/augment (can-insert? x y) + (and read-write? (inner #t can-insert? x y))) + (define/augment (can-delete? x y) + (and read-write? (inner #t can-delete? x y))) + + (define/augment (after-save-file success) + (when success + (check-lock)) + (inner (void) after-save-file success)) + + (define/augment (after-load-file sucessful?) + (when sucessful? + (check-lock)) + (inner (void) after-load-file sucessful?)) + (super-new))) + + (define ports<%> (interface () delete/io @@ -833,7 +869,8 @@ WARNING: printf is rebound in the body of the unit to always get-in-port get-out-port get-err-port - get-value-port)) + get-value-port + after-io-insertion)) (define-struct peeker (bytes skip-count pe resp-chan nack) (make-inspector)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) @@ -1693,7 +1730,7 @@ WARNING: printf is rebound in the body of the unit to always (define -keymap% (editor:keymap-mixin standard-style-list%)) (define return% (return-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%)) - (define file% (editor:file-mixin autowrap%)) + (define file% (file-mixin (editor:file-mixin autowrap%))) (define clever-file-format% (clever-file-format-mixin file%)) (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) (define searching% (searching-mixin backup-autosave%))