..
original commit: 898804df64c0279bdccb43bf3647a0f935de5c90
This commit is contained in:
Robby Findler
parent
eb84c81577
commit
332837e928
|
|
@ -1310,6 +1310,38 @@
|
|||
"Installs the ``Scheme'' preferences panel in the ``Syntax Coloring''"
|
||||
"section.")
|
||||
|
||||
(scheme:get-color-prefs-table
|
||||
(-> (listof (list/p symbol? (is-a?/c color%))))
|
||||
()
|
||||
"Returns a table mapping from symbols (naming the categories that"
|
||||
"the online colorer uses for Scheme mode coloring) to their"
|
||||
"colors."
|
||||
""
|
||||
"These symbols are suitable for input to"
|
||||
"@flink scheme:short-sym->pref-name"
|
||||
"and"
|
||||
"@flink scheme:short-sym->style-name %"
|
||||
".")
|
||||
|
||||
(scheme:short-sym->pref-name
|
||||
(symbol? . -> . symbol?)
|
||||
(short-sym)
|
||||
"Builds the symbol naming the preference from one of the symbols"
|
||||
"in the table returned by"
|
||||
"@flink scheme:get-color-prefs-table %"
|
||||
".")
|
||||
|
||||
(scheme:short-sym->style-name
|
||||
(symbol? . -> . string?)
|
||||
(short-sym)
|
||||
"Builds the symbol naming the editor style from one of the symbols"
|
||||
"in the table returned by"
|
||||
"@flink scheme:get-color-prefs-table %"
|
||||
". This style is a named style in the style list"
|
||||
"returned by"
|
||||
"@flink editor:get-standard-style-list %"
|
||||
".")
|
||||
|
||||
(editor:set-standard-style-list-delta
|
||||
(string? (is-a?/c style-delta%) . -> . void?)
|
||||
(name delta)
|
||||
|
|
@ -1516,7 +1548,25 @@
|
|||
(xyz)
|
||||
"Extracts the z component of \\var{xyz}.")
|
||||
|
||||
|
||||
(color-prefs:register-color-pref
|
||||
(symbol? string? (is-a?/c color%) . -> . void?)
|
||||
(pref-name style-name color)
|
||||
"This function registers a color preference and initializes the"
|
||||
"style list returned from"
|
||||
"@flink editor:get-standard-style-list %"
|
||||
". In particular, it calls "
|
||||
"@flink preferences:set-default "
|
||||
"and "
|
||||
"@flink preferences:set-un/marshall "
|
||||
"to install the pref for \\var{pref-name}, using"
|
||||
"\\var{color} as the default color. The preference"
|
||||
"is bound to a \\iscmclass{style-delta}, and initially the \\iscmclass{style-delta}"
|
||||
"changes the foreground color to \\var{color}."
|
||||
"Then, it calls "
|
||||
"@flink editor:set-standard-style-list-delta"
|
||||
"passing the \\var{style-name} and the newly"
|
||||
"created \\iscmclass{style-delta}.")
|
||||
|
||||
(color-prefs:add-preferences-panel
|
||||
(-> void?)
|
||||
()
|
||||
|
|
@ -1532,34 +1582,4 @@
|
|||
(parent pref-sym style-name example-text)
|
||||
"...")
|
||||
|
||||
(color-prefs:make-style-delta
|
||||
((union string? (is-a?/c color%)) any? any? any? . -> . (is-a?/c style-delta%))
|
||||
(color bold? underline? italic?)
|
||||
"Soon to be deprecated.")
|
||||
(color-prefs:add-staged
|
||||
(string? (listof (list/p symbol? (is-a?/c style-delta%))) . -> . (-> any))
|
||||
(tab-name styles/defaults)
|
||||
"Sets up the preferences defaults for \\var{tab-name} and returns a"
|
||||
"function that will install a panel named \\var{tab-name} in the"
|
||||
"``Syntax Coloring'' section of the preferences dialog."
|
||||
""
|
||||
"\\rawscm{color:prefs-add-staged} can be invoked many times to incrementally add"
|
||||
"styles to a particular tab. However, \\rawscm{color:prefs-add-staged} cannot be"
|
||||
"called after the preferences window is created. Repeated calls to funtions returned"
|
||||
"by \\rawscm{color:prefs-add-staged} for a particular \\var{tab-name} have no effect"
|
||||
"after the first call.")
|
||||
(color-prefs:add
|
||||
(string? (listof (list/p symbol? (is-a?/c style-delta%))) . -> . any)
|
||||
(tab-name styles/defaults)
|
||||
"Same as \\rawscm{color-prefs:add-staged}, except that it immediately"
|
||||
"calls the function for installing the preferences panel.")
|
||||
(color-prefs:get-full-pref-name
|
||||
(string? printable? . -> . symbol?)
|
||||
(tab-name preference-name)
|
||||
"Returns the name of the preference that color-prefs uses for preference"
|
||||
"\\var{preference-name} in \\var{tab-name}.")
|
||||
(color-prefs:get-full-style-name
|
||||
(string? printable? . -> . string?)
|
||||
(tab-name preference-name)
|
||||
"Returns the name of the style that color-prefs uses for preference"
|
||||
"\\var{preference-name} in \\var{tab-name}.")))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -19,28 +19,15 @@
|
|||
[panel : framework:panel^])
|
||||
|
||||
(define standard-style-list-text% (editor:standard-style-list-mixin text%))
|
||||
|
||||
(define (build-many-color-selection-panels symbols tab-name parent)
|
||||
(let ([vp (new vertical-panel% (parent parent))])
|
||||
(for-each
|
||||
(lambda (symbol)
|
||||
(build-color-selection-panel
|
||||
vp
|
||||
(get-full-pref-name tab-name symbol)
|
||||
(get-full-style-name tab-name symbol)
|
||||
(symbol->string symbol)))
|
||||
symbols)))
|
||||
|
||||
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
|
||||
;; constructs a panel containg controls to configure the preferences panel.
|
||||
;; BUG: style changes don't update the check boxes.
|
||||
(define (build-color-selection-panel parent pref-sym style-name example-text)
|
||||
(define hp (new horizontal-panel% (parent parent) (style '(border))))
|
||||
(define delta (preferences:get pref-sym))
|
||||
(define c (make-object editor-canvas% hp
|
||||
#f
|
||||
(list 'hide-hscroll
|
||||
'hide-vscroll)))
|
||||
(define hp (new horizontal-panel%
|
||||
(parent parent)
|
||||
(style '(border))
|
||||
(stretchable-height #f)))
|
||||
(define e (new (class standard-style-list-text%
|
||||
(inherit change-style get-style-list)
|
||||
(rename [super-after-insert after-insert])
|
||||
|
|
@ -52,7 +39,13 @@
|
|||
style-name)])
|
||||
(change-style style pos (+ pos offset) #f)))
|
||||
(super-instantiate ()))))
|
||||
(define c (new editor-canvas%
|
||||
(parent hp)
|
||||
(editor e)
|
||||
(style '(hide-hscroll
|
||||
hide-vscroll))))
|
||||
|
||||
(define delta (preferences:get pref-sym))
|
||||
(define (make-check name on off)
|
||||
(let* ([c (lambda (check command)
|
||||
(if (send check get-value)
|
||||
|
|
@ -116,7 +109,6 @@
|
|||
#t))
|
||||
(editor:set-standard-style-list-delta style-name delta)
|
||||
|
||||
(send c set-editor e)
|
||||
(send e insert example-text)
|
||||
(send e set-position 0)
|
||||
|
||||
|
|
@ -286,75 +278,14 @@
|
|||
(hash-table-put! prefs-panel-mapping (string->symbol name) panel)
|
||||
panel))
|
||||
|
||||
;; prefs-table maps tab-name symbols to either 'too-late or a listof symbols/defaults.
|
||||
;; 'too-late indicates that the preference window has been created and
|
||||
;; additions can no longer be made.
|
||||
(define prefs-table (make-hash-table))
|
||||
|
||||
;; pref-added-table maps tab-name symbols to booleans.
|
||||
;; #t iff the preferences:add call has been made. This is to avoid
|
||||
;; calling add multiple times.
|
||||
(define pref-added-table (make-hash-table))
|
||||
|
||||
(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))))
|
||||
(when (eq? 'too-late current)
|
||||
(error 'color-prefs:add-staged
|
||||
"cannot be invoked after the preferences have already been created for this tab."))
|
||||
(unless current
|
||||
(preferences:set-default active-pref #t (lambda (x) #t))
|
||||
(preferences:add-callback active-pref
|
||||
(lambda (_ on?)
|
||||
(do-active-pref-callbacks tab-name on?))))
|
||||
(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)
|
||||
(editor:set-standard-style-list-delta
|
||||
(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))
|
||||
(lambda ()
|
||||
(unless (hash-table-get pref-added-table tab-name-symbol (lambda () #f))
|
||||
(hash-table-put! pref-added-table tab-name-symbol #t)
|
||||
(preferences:add-panel
|
||||
(list "Junk" sc-syntax-coloring tab-name)
|
||||
(lambda (p)
|
||||
(let ((vp (new vertical-panel% (parent p))))
|
||||
(build-many-color-selection-panels
|
||||
(map car (hash-table-get prefs-table
|
||||
tab-name-symbol
|
||||
(lambda () null)))
|
||||
tab-name
|
||||
vp)
|
||||
(let ((cb (new check-box%
|
||||
(parent vp)
|
||||
(label sc-color-syntax-interactively)
|
||||
(callback (lambda (checkbox y)
|
||||
(preferences:set
|
||||
active-pref
|
||||
(send checkbox get-value)))))))
|
||||
(send cb set-value (preferences:get active-pref)))
|
||||
(hash-table-put! prefs-table tab-name-symbol 'too-late)
|
||||
vp)))))))
|
||||
|
||||
(define (add tab-name symbols/defaults)
|
||||
((add-staged tab-name symbols/defaults)))
|
||||
|
||||
(define (get-full-pref-name tab-name pref-name)
|
||||
(string->symbol (get-full-style-name tab-name pref-name)))
|
||||
|
||||
(define (get-full-style-name tab-name pref-name)
|
||||
(format "syntax-coloring:~a:~a" tab-name pref-name))
|
||||
;; 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.
|
||||
|
|
|
|||
|
|
@ -18,7 +18,8 @@
|
|||
[icon : framework:icon^]
|
||||
[mode : framework:mode^]
|
||||
[text : framework:text^]
|
||||
[color-prefs : framework:color-prefs^])
|
||||
[color-prefs : framework:color-prefs^]
|
||||
[scheme : framework:scheme^])
|
||||
|
||||
(rename [-text<%> text<%>]
|
||||
[-text% text%]
|
||||
|
|
@ -169,7 +170,7 @@
|
|||
(set! colors
|
||||
(cons
|
||||
(let ((color (send (get-style-list) find-named-style
|
||||
(color-prefs:get-full-style-name tab-name type)))
|
||||
(scheme:short-sym->style-name type)))
|
||||
(sp (+ in-start-pos (sub1 new-token-start)))
|
||||
(ep (+ in-start-pos (sub1 new-token-end))))
|
||||
(lambda ()
|
||||
|
|
@ -292,8 +293,7 @@
|
|||
(unless force-stop?
|
||||
(set! stopped? #f)
|
||||
(reset-tokens)
|
||||
(set! should-color?
|
||||
(preferences:get (color-prefs:get-full-pref-name tab-name- "active")))
|
||||
(set! should-color? (preferences:get 'framework:coloring-active))
|
||||
(set! tab-name tab-name-)
|
||||
(set! get-token get-token-)
|
||||
(set! pairs pairs-)
|
||||
|
|
@ -321,8 +321,8 @@
|
|||
(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)))
|
||||
|
|
|
|||
|
|
@ -373,14 +373,15 @@
|
|||
|
||||
;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void
|
||||
(define (set-standard-style-list-delta name delta)
|
||||
(let* ([style-list (editor:get-standard-style-list)]
|
||||
(let* ([style-list (get-standard-style-list)]
|
||||
[style (send style-list find-named-style name)])
|
||||
(if style
|
||||
(send style set-delta delta)
|
||||
(send style-list new-named-style name
|
||||
(send style-list find-or-create-style
|
||||
(send style-list find-named-style "Standard")
|
||||
delta)))))
|
||||
delta)))
|
||||
(void)))
|
||||
|
||||
(define -keymap<%> (interface (basic<%>) get-keymaps))
|
||||
(define keymap-mixin
|
||||
|
|
|
|||
|
|
@ -184,6 +184,19 @@
|
|||
(lambda (x)
|
||||
(or (eq? x 'common)
|
||||
(eq? x 'std))))
|
||||
|
||||
;; scheme prefs
|
||||
|
||||
(for-each (lambda (line)
|
||||
(let ([sym (car line)]
|
||||
[color (cadr line)])
|
||||
(color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
|
||||
(scheme:short-sym->style-name sym)
|
||||
color)))
|
||||
(scheme:get-color-prefs-table))
|
||||
(preferences:set-default 'framework:coloring-active #t boolean?)
|
||||
;; need to add in the editor checkbox.
|
||||
|
||||
|
||||
;; groups
|
||||
|
||||
|
|
@ -217,5 +230,4 @@
|
|||
(preferences:set 'framework:file-dialogs 'std)
|
||||
(preferences:set 'framework:exit-when-no-frames #t)
|
||||
|
||||
(scheme:add-coloring-preferences-panel)
|
||||
(void))))
|
||||
|
|
|
|||
|
|
@ -258,43 +258,34 @@
|
|||
;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;; ; ;;; ;;; ;; ;; ;;;
|
||||
|
||||
|
||||
;; 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.
|
||||
;; 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 color-prefs-table
|
||||
`((symbol ,(make-object color% 38 38 128) ,(string-constant scheme-mode-color-symbol))
|
||||
(keyword ,(make-object color% 38 38 128) ,(string-constant scheme-mode-color-keyword))
|
||||
(comment ,(make-object color% 194 116 31) ,(string-constant scheme-mode-color-comment))
|
||||
(string ,(make-object color% "forestgreen") ,(string-constant scheme-mode-color-string))
|
||||
(constant ,(make-object color% "forestgreen") ,(string-constant scheme-mode-color-constant))
|
||||
(parenthesis ,(make-object color% "brown") ,(string-constant scheme-mode-color-parenthesis))
|
||||
(error ,(make-object color% "red") ,(string-constant scheme-mode-color-error))
|
||||
(other ,(make-object color% "black") ,(string-constant scheme-mode-color-other))))
|
||||
(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 (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
|
||||
"Scheme"
|
||||
`((lexically-bound-variable
|
||||
,(color-prefs:make-style-delta (make-object color% 255 0 0) #f #f #f))
|
||||
(lexically-bound-syntax
|
||||
,(color-prefs:make-style-delta (make-object color% 0 0 255) #f #f #f))
|
||||
(imported-syntax
|
||||
,(color-prefs:make-style-delta (make-object color% 255 0 255) #f #f #f))
|
||||
(imported-variable
|
||||
,(color-prefs:make-style-delta (make-object color% 0 255 255) #f #f #f))))
|
||||
|
||||
|
||||
(color-prefs:add-to-preferences-panel
|
||||
"Scheme"
|
||||
(lambda (parent)
|
||||
(for-each
|
||||
(lambda (line)
|
||||
(let ([sym (car line)])
|
||||
(color-prefs:build-color-selection-panel
|
||||
parent
|
||||
(short-sym->pref-name sym)
|
||||
(short-sym->style-name sym)
|
||||
(format "~a" sym))))
|
||||
color-prefs-table))))
|
||||
|
||||
(define-struct string/pos (string pos))
|
||||
|
||||
(define -text<%>
|
||||
|
|
|
|||
|
|
@ -521,16 +521,12 @@
|
|||
(define-signature framework:color-prefs-class^
|
||||
())
|
||||
(define-signature framework:color-prefs-fun^
|
||||
(make-style-delta ;; to be gone
|
||||
add ;; to be gone
|
||||
add-staged ;; to be gone
|
||||
(register-color-pref
|
||||
add-to-preferences-panel
|
||||
add-preferences-panel
|
||||
build-color-selection-panel
|
||||
register-active-pref-callback
|
||||
remove-active-pref-callback
|
||||
get-full-pref-name
|
||||
get-full-style-name))
|
||||
remove-active-pref-callback))
|
||||
(define-signature framework:color-prefs^
|
||||
((open framework:color-prefs-class^)
|
||||
(open framework:color-prefs-fun^)))
|
||||
|
|
@ -555,7 +551,11 @@
|
|||
get-keymap
|
||||
setup-keymap
|
||||
add-preferences-panel
|
||||
add-coloring-preferences-panel))
|
||||
add-coloring-preferences-panel
|
||||
|
||||
get-color-prefs-table
|
||||
short-sym->pref-name
|
||||
short-sym->style-name))
|
||||
(define-signature framework:scheme^
|
||||
((open framework:scheme-class^)
|
||||
(open framework:scheme-fun^)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user