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

*** empty log message ***

Browse Source 
original commit: 8448b16fa2c4483a9317b6183e5b9b62880d204a
This commit is contained in:
Scott Owens 2003-12-05 10:33:51 +00:00
parent 524280b693
commit b2dd2f5c15
3 changed files with 41 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -24,7 +24,7 @@
(define sym (get-full-pref-name tab-name symbol))
(define delta (preferences:get sym))
(define style-name (symbol->string sym))
(define style-name (get-full-style-name tab-name symbol))
(define c (make-object editor-canvas% this
#f
(list 'hide-hscroll
@ -44,9 +44,9 @@
(super-instantiate ()))))
(preferences:add-callback sym
(lambda (sym v)
(set-slatex-style sym v)
(set-slatex-style style-name v)
#t))
(set-slatex-style sym delta)
(set-slatex-style style-name delta)
(define (make-check name on off)
(let* ([c (lambda (check command)
(if (send check get-value)
@ -167,10 +167,9 @@
(lambda (x)
(is-a? x style-delta%))))
; a symbol naming the style and a delta to set it to
(define (set-slatex-style sym delta)
; a string naming the style and a delta to set it to
(define (set-slatex-style name delta)
(let* ([style-list (editor:get-standard-style-list)]
[name (symbol->string sym)]
[style (send style-list find-named-style name)])
(if style
(send style set-delta delta)
@ -228,9 +227,7 @@
(define (add-staged tab-name symbols/defaults)
(let* ((tab-name-symbol (string->symbol tab-name))
(active-pref (get-full-pref-name tab-name "active"))
(current (hash-table-get prefs-table tab-name-symbol (lambda () #f)))
(syms (map (lambda (s/d) (get-full-pref-name tab-name (car s/d)))
symbols/defaults)))
(current (hash-table-get prefs-table tab-name-symbol (lambda () #f))))
(when (eq? 'too-late current)
(error 'color-prefs:add-staged
"cannot be invoked after the preferences have already been created for this tab."))
@ -239,11 +236,17 @@
(preferences:add-callback active-pref
(lambda (_ on?)
(do-active-pref-callbacks tab-name on?))))
(for-each set-default syms (map cadr symbols/defaults))
(for-each (lambda (s)
(preferences:set-un/marshall s marshall-style unmarshall-style))
syms)
(for-each set-slatex-style syms (map preferences:get syms))
(for-each (lambda (s/d)
(set-default (get-full-pref-name tab-name (car s/d)) (cadr s/d)))
symbols/defaults)
(for-each (lambda (s/d)
(preferences:set-un/marshall (get-full-pref-name tab-name (car s/d))
marshall-style unmarshall-style))
symbols/defaults)
(for-each (lambda (s/d)
(set-slatex-style (get-full-style-name tab-name (car s/d))
(preferences:get (get-full-pref-name tab-name (car s/d)))))
symbols/defaults)
(hash-table-put! prefs-table
tab-name-symbol
(append (if current current null) symbols/defaults))

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

@ -17,7 +17,8 @@
[group : framework:group^]
[handler : framework:handler^]
[editor : framework:editor^]
[color-prefs : framework:color-prefs^])
[color-prefs : framework:color-prefs^]
[scheme : framework:scheme^])
(application-preferences-handler (lambda () (preferences:show-dialog)))
@ -216,5 +217,5 @@
(preferences:set 'framework:file-dialogs 'std)
(preferences:set 'framework:exit-when-no-frames #t)
(scheme:add-coloring-preferences-panel)
(void))))

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

@ -257,21 +257,30 @@
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ; ;;; ;;; ;; ;; ;;;
;; This adds the preferences that scheme:text% needs for coloring
;; It returns a thunk that, when invoked will setup the panel in the
;; preferences dialog.
(define add-coloring-preferences-panel
(color-prefs:add-staged
"Scheme"
`((symbol ,(color-prefs:make-style-delta "navy" #f #f #f))
(keyword ,(color-prefs:make-style-delta "navy" #f #f #f))
(comment ,(color-prefs:make-style-delta (make-object color% 0 105 255) #f #f #f))
(string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f))
(constant ,(color-prefs:make-style-delta (make-object color% 51 135 39) #f #f #f))
(parenthesis ,(color-prefs:make-style-delta "brown" #f #f #f))
(error ,(color-prefs:make-style-delta "red" #f #f #f))
(other ,(color-prefs:make-style-delta "black" #f #f #f)))))
;; It uses the set! trick because it needs to not call add-staged
;; until the preferences has been turned on in main.ss
(define add-coloring-pref-state #f)
(define (add-coloring-preferences-panel)
(cond
(add-coloring-pref-state
(add-coloring-pref-state))
(else
(set! add-coloring-pref-state
(color-prefs:add-staged
"Scheme"
`((symbol ,(color-prefs:make-style-delta "navy" #f #f #f))
(keyword ,(color-prefs:make-style-delta "navy" #f #f #f))
(comment ,(color-prefs:make-style-delta (make-object color% 0 105 255) #f #f #f))
(string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f))
(constant ,(color-prefs:make-style-delta (make-object color% 51 135 39) #f #f #f))
(parenthesis ,(color-prefs:make-style-delta "brown" #f #f #f))
(error ,(color-prefs:make-style-delta "red" #f #f #f))
(other ,(color-prefs:make-style-delta "black" #f #f #f))))))))
;; for check syntax (to be moved elsewhere)
(color-prefs:add-staged