*** empty log message ***
original commit: f8a7d47521577a47638830879a04f61101c459dd
This commit is contained in:
parent
9c2414e13c
commit
506ffddc58
|
@ -1510,5 +1510,13 @@
|
|||
(color-model:xyz-z
|
||||
(color-model:xyz? . -> . number?)
|
||||
(xyz)
|
||||
"Extracts the z component of \\var{xyz}.")))
|
||||
|
||||
"Extracts the z component of \\var{xyz}.")
|
||||
(color-prefs:make-style-delta
|
||||
((union string? (is-a?/c color%)) any? any? any? . -> . (is-a?/c style-delta%))
|
||||
(color bold? underline? italic?)
|
||||
"")
|
||||
(color-prefs:add
|
||||
(string? (listof (list/p symbol? (is-a?/c style-delta%))) . -> . any)
|
||||
(tab-name styles/defaults)
|
||||
"")))
|
||||
|
||||
|
|
|
@ -214,7 +214,6 @@
|
|||
symbols)
|
||||
))
|
||||
|
||||
|
||||
(define (add tab-name symbols/defaults)
|
||||
(let* ((prefix (string->symbol (format "syntax-coloring:~a" tab-name)))
|
||||
(active-pref (string->symbol (format "~a:active" prefix)))
|
||||
|
@ -241,4 +240,31 @@
|
|||
active-pref
|
||||
(send checkbox get-value)))))))
|
||||
(send cb set-value (preferences:get active-pref)))
|
||||
vp))))))))
|
||||
vp)))
|
||||
(preferences:add-callback active-pref
|
||||
(lambda (_ on?)
|
||||
(do-active-pref-callbacks active-pref on?)))))
|
||||
|
||||
|
||||
;; 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))
|
||||
|
||||
(define (do-active-pref-callbacks pref-sym on?)
|
||||
(hash-table-for-each (hash-table-get active-pref-callback-table pref-sym (lambda () (make-hash-table)))
|
||||
(lambda (k v)
|
||||
(v k on?))))
|
||||
|
||||
(define (remove-active-pref-callback pref-sym k)
|
||||
(let ((ht (hash-table-get active-pref-callback-table pref-sym (lambda () #f))))
|
||||
(when ht
|
||||
(hash-table-remove! ht k))))
|
||||
|
||||
(define (register-active-pref-callback pref-sym k v)
|
||||
(hash-table-put! (hash-table-get active-pref-callback-table pref-sym
|
||||
(lambda ()
|
||||
(let ((ht (make-hash-table 'weak)))
|
||||
(hash-table-put! active-pref-callback-table pref-sym ht)
|
||||
ht)))
|
||||
k v)))))
|
||||
|
||||
|
|
|
@ -11,13 +11,14 @@
|
|||
|
||||
|
||||
(provide color@)
|
||||
|
||||
|
||||
(define color@
|
||||
(unit/sig framework:color^
|
||||
(import [preferences : framework:preferences^]
|
||||
[icon : framework:icon^]
|
||||
[mode : framework:mode^]
|
||||
[text : framework:text^])
|
||||
[text : framework:text^]
|
||||
[color-prefs : framework:color-prefs^])
|
||||
|
||||
(rename [-text<%> text<%>]
|
||||
[-text% text%]
|
||||
|
@ -30,6 +31,11 @@
|
|||
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<%>)
|
||||
;; ---------------------- Lexing state ----------------------------------
|
||||
|
@ -84,7 +90,6 @@
|
|||
|
||||
;; ---------------------- Preferences -----------------------------------
|
||||
(define should-color? #t)
|
||||
(define remove-prefs-callback-thunk #f)
|
||||
(define prefix #f)
|
||||
|
||||
(define/public (coloring-active?)
|
||||
|
@ -269,20 +274,10 @@
|
|||
(set! get-token get-token-)
|
||||
(set! pairs pairs-)
|
||||
(set! parens (new paren-tree% (matches pairs)))
|
||||
(unless remove-prefs-callback-thunk
|
||||
(set! remove-prefs-callback-thunk
|
||||
(preferences:add-callback
|
||||
(string->symbol (format "syntax-coloring:~a:active" prefix))
|
||||
(lambda (_ on?)
|
||||
(cond
|
||||
((and (not should-color?) on?)
|
||||
(set! should-color? #t)
|
||||
(reset-tokens)
|
||||
(do-insert/delete start-pos 0))
|
||||
((and should-color? (not on?))
|
||||
(set! should-color? #f)
|
||||
(change-style (send (get-style-list) find-named-style "Standard")
|
||||
start-pos end-pos #f)))))))
|
||||
(color-prefs:register-active-pref-callback
|
||||
(string->symbol (format "syntax-coloring:~a:active" prefix))
|
||||
this
|
||||
active-cb)
|
||||
(unless background-thread
|
||||
(break-enabled #f)
|
||||
(set! background-thread (thread (lambda () (background-colorer-entry))))
|
||||
|
@ -291,9 +286,9 @@
|
|||
|
||||
(define/public (stop-colorer)
|
||||
(set! stopped? #t)
|
||||
(when remove-prefs-callback-thunk
|
||||
(remove-prefs-callback-thunk)
|
||||
(set! remove-prefs-callback-thunk #f))
|
||||
(color-prefs:remove-active-pref-callback
|
||||
(string->symbol (format "syntax-coloring:~a:active" prefix))
|
||||
this)
|
||||
(change-style (send (get-style-list) find-named-style "Standard")
|
||||
start-pos end-pos #f)
|
||||
(match-parens #t)
|
||||
|
@ -302,7 +297,18 @@
|
|||
(set! prefix #f)
|
||||
(set! get-token #f))
|
||||
|
||||
|
||||
(define/public (toggle-color on?)
|
||||
(cond
|
||||
((and (not should-color?) on?)
|
||||
(set! should-color? #t)
|
||||
(reset-tokens)
|
||||
(do-insert/delete start-pos 0))
|
||||
((and should-color? (not on?))
|
||||
(set! should-color? #f)
|
||||
(change-style (send (get-style-list) find-named-style "Standard")
|
||||
start-pos end-pos #f))))
|
||||
|
||||
|
||||
(define/public (force-stop-colorer x)
|
||||
(set! force-stop? x)
|
||||
(when x
|
||||
|
@ -310,7 +316,7 @@
|
|||
(when background-thread
|
||||
(kill-thread background-thread)
|
||||
(set! background-thread #f))))
|
||||
|
||||
|
||||
|
||||
;; ----------------------- Match parentheses ----------------------------
|
||||
|
||||
|
@ -414,14 +420,7 @@
|
|||
(define/override (after-delete edit-start-pos change-length)
|
||||
(do-insert/delete edit-start-pos (- change-length))
|
||||
(super-after-delete edit-start-pos change-length))
|
||||
|
||||
(rename (super-on-close on-close))
|
||||
(define/override (on-close)
|
||||
(when remove-prefs-callback-thunk
|
||||
(remove-prefs-callback-thunk)
|
||||
(set! remove-prefs-callback-thunk #f))
|
||||
(super-on-close))
|
||||
|
||||
|
||||
(rename (super-change-style change-style))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
|
|
@ -218,7 +218,7 @@
|
|||
|
||||
;; This adds the preferences that scheme:text% needs for coloring
|
||||
(color-prefs:add
|
||||
"Scheme Color"
|
||||
"Scheme"
|
||||
`((symbol ,(color-prefs:make-style-delta "navy" #f #f #f))
|
||||
(keyword ,(color-prefs:make-style-delta (make-object color% 40 25 15) #f #f #f))
|
||||
(unbound-variable ,(color-prefs:make-style-delta "red" #f #f #f))
|
||||
|
|
|
@ -1036,7 +1036,7 @@
|
|||
(send text end-edit-sequence))
|
||||
|
||||
(super-new (get-token scheme-lexer-wrapper)
|
||||
(prefix "Scheme Color")
|
||||
(prefix "Scheme")
|
||||
(matches '((|(| |)|)
|
||||
(|[| |]|)
|
||||
(|{| |}|))))))
|
||||
|
|
|
@ -519,9 +519,9 @@
|
|||
(open framework:color-fun^)))
|
||||
|
||||
(define-signature framework:color-prefs-class^
|
||||
(make-style-delta add))
|
||||
(define-signature framework:color-prefs-fun^
|
||||
())
|
||||
(define-signature framework:color-prefs-fun^
|
||||
(make-style-delta add register-active-pref-callback remove-active-pref-callback))
|
||||
(define-signature framework:color-prefs^
|
||||
((open framework:color-prefs-class^)
|
||||
(open framework:color-prefs-fun^)))
|
||||
|
|
Loading…
Reference in New Issue
Block a user