diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 1552ea7147..97dace35a3 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -1,50 +1,28 @@ -#| - -todo: - - -read - -|# #| -save needs contracts +There are three attributes for each preference: -showing the dialog needs preferences. - -There are four attributes for each preference (technically, "read from -disk" is global, but we can just think of it happening to each one -independently, but simultaneously): - - - read from disk, or not - default set, or not - marshalling function set, or not - initialization still okay, or not the state transitions / contracts are: - get(true, true, _, _) -> (true, true, _, false) - get(false, _, _, _) -> error not yet read from disk - get(_, false, _, _) -> error default not yet set + get(true, _, _) -> (true, _, false) + get(false, _, _) -> error default not yet set set is just like get. - set-default(true, false, true, true) -> set-default(true, true, _, true) - set-default(false, _, _, _) -> error not yet read from disk - set-default(_, true, _, _) -> error default already set - set-default(_, _, _, false) -> initialization not okay anymore /* cannot happen, I think */ + set-default(false, _, true) -> set-default(true, _, true) + set-default(true, _, _) -> error default already set + set-default(_, _, false) -> initialization not okay anymore /* cannot happen, I think */ - set-un/marshall(true, true, false, true) -> (true, true, true, true) + set-un/marshall(true, false, true) -> (true, true, true) .. otherwise error - read(false, _, _, true) -> (true, _, _, true) - read(true, _, _, _) -> error, already read from disk - read(_, _, _, false) -> initialization phase over /* cannot happen */ - for all syms: - prefs-snapshot(true, _, _, _) -> (true, _, _, false) - -for the last one, need a global "no more initialization can happen" flag. + prefs-snapshot(_, _, _) -> (_, _, false) |# @@ -116,12 +94,11 @@ for the last one, need a global "no more initialization can happen" flag. (define (get p) (cond [(pref-default-set? p) - (let/ec k - (unmarshall - p - (get-preference (add-pref-prefix p) - (λ () - (k (default-value (hash-table-get defaults p)))))))] + (let* ([g (gensym)] + [pref (get-preference (add-pref-prefix p) (λ () g))]) + (if (eq? g pref) + (default-value (hash-table-get defaults p)) + (unmarshall p pref)))] [(not (pref-default-set? p)) (raise-unknown-preference-error 'preferences:get diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 7ae723ee2e..830ac63f23 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -420,7 +420,8 @@ (define (tabify-on-return?) #t) (define tabify (opt-lambda ([pos (get-start-position)]) - (let* ([last-pos (last-position)] + (let* ([tabify-prefs (preferences:get 'framework:tabify)] + [last-pos (last-position)] [para (position-paragraph pos)] [is-tabbable? (and (> para 0) (not (memq (classify-position (sub1 (paragraph-start-position para))) @@ -486,7 +487,7 @@ (let ([id-end (get-forward-sexp contains)]) (if (and id-end (> id-end contains)) (let* ([text (get-text contains id-end)]) - (or (get-keyword-type text) + (or (get-keyword-type text tabify-prefs) 'other)))))] [procedure-indent (λ () @@ -1027,25 +1028,29 @@ (send text set-styles-fixed #t) (send text end-edit-sequence)) - (super-new (get-token scheme-lexer-wrapper) + (define tabify-pref (preferences:get 'framework:tabify)) + (preferences:add-callback + 'framework:tabify + (lambda (k v) (set! tabify-pref v))) + (define/private (scheme-lexer-wrapper in) + (let-values (((lexeme type paren start end) (scheme-lexer in))) + (cond + ((and (eq? type 'symbol) + (get-keyword-type lexeme tabify-pref)) + (values lexeme 'keyword paren start end)) + (else + (values lexeme type paren start end))))) + + (super-new (get-token (lambda (in) (scheme-lexer-wrapper in))) (token-sym->style short-sym->style-name) (matches '((|(| |)|) (|[| |]|) (|{| |}|)))))) - (define (scheme-lexer-wrapper in) - (let-values (((lexeme type paren start end) (scheme-lexer in))) - (cond - ((and (eq? type 'symbol) - (get-keyword-type lexeme)) - (values lexeme 'keyword paren start end)) - (else - (values lexeme type paren start end))))) - - ;; get-keyword-type : string -> (union #f 'lambda 'define 'begin) - (define (get-keyword-type text) - (let* ([pref (preferences:get 'framework:tabify)] - [ht (car pref)] + ;; get-keyword-type : string (list ht regexp regexp regexp) + ;; -> (union #f 'lambda 'define 'begin) + (define (get-keyword-type text pref) + (let* ([ht (car pref)] [beg-reg (cadr pref)] [def-reg (caddr pref)] [lam-reg (cadddr pref)])