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

*** empty log message ***

Browse Source 
original commit: f8a7d47521577a47638830879a04f61101c459dd
This commit is contained in:
Scott Owens 2003-12-04 01:11:26 +00:00
parent 9c2414e13c
commit 506ffddc58
6 changed files with 71 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/framework/framework.ss
View File

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

30
collects/framework/private/color-prefs.ss
View File

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

59
collects/framework/private/color.ss
View File

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

2
collects/framework/private/main.ss
View File

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

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

@ -1036,7 +1036,7 @@
(send text end-edit-sequence))
(super-new (get-token scheme-lexer-wrapper)
(prefix "Scheme Color")
(prefix "Scheme")
(matches '((|(| |)|)
(|[| |]|)
(|{| |}|))))))

4
collects/framework/private/sig.ss
View File

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