..
original commit: 49ea309608f4e4b4a56e3c0ee6a63dd639427903
This commit is contained in:
Robby Findler
parent
332837e928
commit
5ace21a45d
|
|
@ -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.")
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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%))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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^)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user