From 5ace21a45db993b148c6779fdfb79821c9a012a1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 10 Dec 2003 03:51:55 +0000 Subject: [PATCH] .. original commit: 49ea309608f4e4b4a56e3c0ee6a63dd639427903 --- collects/framework/framework.ss | 23 +++- collects/framework/private/color-prefs.ss | 34 +----- collects/framework/private/color.ss | 23 ++-- collects/framework/private/preferences.ss | 125 +++++++++++++--------- collects/framework/private/scheme.ss | 2 +- collects/framework/private/sig.ss | 4 +- 6 files changed, 110 insertions(+), 101 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index f48369d9..dec0511a 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -98,13 +98,18 @@ "\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}" "if the preference has not been set.") (preferences:add-callback - (symbol? (symbol? any? . -> . any?) . -> . (-> void?)) - (p f) + (opt-> (symbol? (symbol? any? . -> . any?)) + (boolean?) + (-> void?)) + (p f (weak? #f)) "This function adds a callback which is called with a symbol naming a" "preference and it's value, when the preference changes." "\\rawscm{preferences:add-callback} returns a thunk, which when" "invoked, removes the callback from this preference." "" + "If \\var{weak?} is true, the preferences system will only hold on to" + "the callback weakly." + "" "The callbacks will be called in the order in which they were added." "" "If you are adding a callback for a preference that requires" @@ -1580,6 +1585,18 @@ (color-prefs:build-color-selection-panel ((is-a?/c area-container<%>) symbol? string? string? . -> . void?) (parent pref-sym style-name example-text) - "...") + "Builds a panel with a number of controls for configuring" + "a font: the color and check boxes for bold, italic, and underline." + "The \\var{parent} argument specifies where the panel will be" + "placed. The \\var{pref-sym} should be a preference (suitable for" + "use with" + "@flink preferences:get " + "and" + "@flink preferences:set %" + "). The \\var{style-name} specifies the name of a style in the" + "style list returned from" + "@flink editor:get-standard-style-list" + "and \\var{example-text} is shown in the panel so users can see" + "the results of their configuration.") )) diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 1ffee22f..55b1f760 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -278,43 +278,11 @@ (hash-table-put! prefs-panel-mapping (string->symbol name) panel) panel)) - ;; see docs (define (register-color-pref pref-name style-name color) (let ([sd (new style-delta%)]) (send sd set-delta-foreground color) (preferences:set-default pref-name sd (lambda (x) (is-a? x style-delta%))) (preferences:set-un/marshall pref-name marshall-style unmarshall-style) - (editor:set-standard-style-list-delta style-name sd))) - - ;; The following 4 defines are a mini-prefs system that uses a weak hash table - ;; so the preferences won't hold on to a text when it should otherwise be GCed. - (define active-pref-callback-table (make-hash-table)) - - ;; string? any? -> - (define (do-active-pref-callbacks tab-name on?) - (hash-table-for-each (hash-table-get active-pref-callback-table - (string->symbol tab-name) - (lambda () (make-hash-table))) - (lambda (k v) - (v k on?)))) - - ;; string? any? -> - (define (remove-active-pref-callback tab-name k) - (let ((ht (hash-table-get active-pref-callback-table - (string->symbol tab-name) - (lambda () #f)))) - (when ht - (hash-table-remove! ht k)))) - - ;; string? any? any? -> - (define (register-active-pref-callback tab-name k v) - (hash-table-put! (hash-table-get active-pref-callback-table (string->symbol tab-name) - (lambda () - (let ((ht (make-hash-table 'weak))) - (hash-table-put! active-pref-callback-table - (string->symbol tab-name) - ht) - ht))) - k v))))) + (editor:set-standard-style-list-delta style-name sd)))))) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 1b8adb31..f9ca51ce 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -36,12 +36,7 @@ reset-region update-region-end)) - - (define-local-member-name toggle-color) - (define (active-cb text on?) - (send text toggle-color on?)) - (define text-mixin (mixin (text:basic<%>) (-text<%>) ;; ---------------------- Coloring modes ---------------------------- @@ -298,7 +293,6 @@ (set! get-token get-token-) (set! pairs pairs-) (set! parens (new paren-tree% (matches pairs))) - (color-prefs:register-active-pref-callback tab-name this active-cb) (unless background-thread (break-enabled #f) (set! background-thread (thread (lambda () (background-colorer-entry)))) @@ -308,7 +302,6 @@ (define/public stop-colorer (opt-lambda ((clear-colors #t)) (set! stopped? #t) - (color-prefs:remove-active-pref-callback tab-name this) (when clear-colors (change-style (send (get-style-list) find-named-style "Standard") start-pos end-pos #f)) @@ -321,8 +314,10 @@ (define/public (freeze-colorer) (when (is-locked?) (error 'freeze-colorer "called on a locked color:text<%>.")) - #;(when (in-edit-sequence?) - (error 'freeze-colorer "called on a color:text<%> while in an edit sequence.")) + #| + (when (in-edit-sequence?) + (error 'freeze-colorer "called on a color:text<%> while in an edit sequence.")) + |# (unless frozen? (finish-now) (set! frozen? #t))) @@ -337,7 +332,7 @@ (stop-colorer (not should-color?)) (start-colorer tn gt p))))) - (define/public (toggle-color on?) + (define/private (toggle-color on?) (cond ((and frozen? (not (equal? on? should-color?))) (set! restart-after-freeze #t)) @@ -474,7 +469,13 @@ (rename (super-change-style change-style)) - (super-instantiate ()))) + (super-new) + + ;; need pref-callback to be in a private field + ;; so that the editor hangs on to the callback + ;; when the editor goes away, so does the callback + (define (pref-callback k v) (toggle-color v)) + (preferences:add-callback 'framework:coloring-active pref-callback #t))) (define -text% (text-mixin text:keymap%)) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 4c02e775..227a88bc 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -4,7 +4,8 @@ (lib "unitsig.ss") (lib "class.ss") (lib "file.ss") - "sig.ss" + (lib "etc.ss") + "sig.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") (lib "pretty.ss") @@ -96,8 +97,16 @@ (reset-changed)))))))) (define guard - (lambda (when p value thunk failure) - (with-handlers ([not-break-exn? failure]) + (lambda (when p value thunk) + (with-handlers ([not-break-exn? + (lambda (exn) + (error "excetion raised ~s, pref ~s val ~s, msg: ~a" + when + p + value + (if (exn? exn) + (exn-message exn) + (format "~s" exn))))]) (thunk)))) (define (unmarshall p marshalled) @@ -107,59 +116,72 @@ (hash-table-get marshall-unmarshall p (lambda () (k data))))]) - (guard "unmarshalling" p marshalled - (lambda () (unmarshall-fn data)) - (lambda (exn) - (begin0 - (hash-table-get - defaults - p - (lambda () - (raise exn))) - (message-box (format (string-constant error-unmarshalling) p) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn))))))))) + (with-handlers ([not-break-exn? + (lambda (exn) + (begin0 + (hash-table-get defaults p (lambda () (raise exn))) + (message-box (format (string-constant error-unmarshalling) p) + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn)))))]) + (unmarshall-fn data))))) - ;; get-callbacks : sym -> (listof (-> void)) - (define (get-callbacks p) - (hash-table-get callbacks - p - (lambda () null))) - - ;; pref-callback : (make-pref-callback (sym tst -> void)) + ;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void))) ;; this is used as a wrapped to hack around the problem ;; that different procedures might be eq?. (define-struct pref-callback (cb)) ;; add-callback : sym (-> void) -> void - (define (add-callback p callback) - (let ([new-cb (make-pref-callback callback)]) - (hash-table-put! callbacks p - (append - (hash-table-get callbacks p (lambda () null)) - (list new-cb))) - (lambda () - (hash-table-put! - callbacks - p - (let loop ([callbacks (hash-table-get callbacks p (lambda () null))]) - (cond - [(null? callbacks) null] - [else - (let ([callback (car callbacks)]) - (cond - [(eq? callback new-cb) - (loop (cdr callbacks))] - [else - (cons (car callbacks) (loop (cdr callbacks)))]))])))))) + (define add-callback + (opt-lambda (p callback [weak? #f]) + (let ([new-cb (make-pref-callback (if weak? + (make-weak-box callback) + callback))]) + (hash-table-put! callbacks + p + (append + (hash-table-get callbacks p (lambda () null)) + (list new-cb))) + (lambda () + (hash-table-put! + callbacks + p + (let loop ([callbacks (hash-table-get callbacks p (lambda () null))]) + (cond + [(null? callbacks) null] + [else + (let ([callback (car callbacks)]) + (cond + [(eq? callback new-cb) + (loop (cdr callbacks))] + [else + (cons (car callbacks) (loop (cdr callbacks)))]))]))))))) + ;; check-callbacks : sym val -> void (define (check-callbacks p value) - (for-each (lambda (x) - (guard "calling callback" p value - (lambda () ((pref-callback-cb x) p value)) - raise)) - (get-callbacks p))) + (let ([new-callbacks + (let loop ([callbacks (hash-table-get callbacks p (lambda () null))]) + (cond + [(null? callbacks) null] + [else + (let* ([callback (car callbacks)] + [cb (pref-callback-cb callback)]) + (cond + [(weak-box? cb) + (let ([v (weak-box-value cb)]) + (if v + (begin + (guard "calling callback" p value + (lambda () (v p value))) + (cons callback (loop (cdr callbacks)))) + (loop (cdr callbacks))))] + [else + (guard "calling callback" p value + (lambda () (cb p value))) + (cons callback (loop (cdr callbacks)))]))]))]) + (if (null? new-callbacks) + (hash-table-remove! callbacks p) + (hash-table-put! callbacks p new-callbacks)))) (define (get p) (let ([ans (hash-table-get preferences p @@ -290,8 +312,7 @@ (hash-table-get marshall-unmarshall p (lambda () (k value)))) - value)) - raise))]) + value))))]) (list p marshalled))] [else (error 'prefs.ss "robby error.2: ~a" ht-value)])) @@ -751,6 +772,10 @@ 'framework:menu-bindings (string-constant enable-keybindings-in-menus) values values) + (make-check editor-panel + 'framework:coloring-active + (string-constant online-coloring-active) + values values) (unless (eq? (system-type) 'unix) (make-check editor-panel 'framework:print-output-mode diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 7edfceeb..349ef192 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -270,7 +270,7 @@ (define (get-color-prefs-table) color-prefs-table) (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) - (define (short-sym->style-name sym) (format "syntax-coloring:Scheme:~a" sym)) + (define (short-sym->style-name sym) (format "framework:syntax-coloring:scheme:~a" sym)) (define (add-coloring-preferences-panel) (color-prefs:add-to-preferences-panel diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 0b8c2be1..2e8bd19f 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -524,9 +524,7 @@ (register-color-pref add-to-preferences-panel add-preferences-panel - build-color-selection-panel - register-active-pref-callback - remove-active-pref-callback)) + build-color-selection-panel)) (define-signature framework:color-prefs^ ((open framework:color-prefs-class^) (open framework:color-prefs-fun^)))