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

fixed a bug and improved note at top of preferences.ss

Browse Source 
svn: r5060
This commit is contained in:
Robby Findler 2006-12-08 02:54:00 +00:00
parent e6945544dc
commit aa26769184
2 changed files with 34 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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)])