.
original commit: 41b04ef3c618c5a3c35c9e57d73e7aa422418030
This commit is contained in:
Robby Findler
parent
8c72da58aa
commit
edf73ab783
|
|
@ -1327,6 +1327,13 @@
|
|||
"@flink editor:get-standard-style-list %"
|
||||
".")
|
||||
|
||||
(editor:update-standard-style
|
||||
(-> (-> (is-a?/c style-delta%) void?) void?)
|
||||
(change-delta)
|
||||
"Calls \\var{change-delta} with the \"Standard\" style delta from"
|
||||
"the result of"
|
||||
"@flink editor:get-standard-style-list %"
|
||||
".")
|
||||
(editor:set-standard-style-list-delta
|
||||
(string? (is-a?/c style-delta%) . -> . void?)
|
||||
(name delta)
|
||||
|
|
|
|||
|
|
@ -24,90 +24,98 @@
|
|||
;; 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))
|
||||
(stretchable-height #f)))
|
||||
(define e (new (class standard-style-list-text%
|
||||
(inherit change-style get-style-list)
|
||||
(define/augment (after-insert pos offset)
|
||||
(inner (void) after-insert pos offset)
|
||||
(let ([style (send (get-style-list)
|
||||
find-named-style
|
||||
style-name)])
|
||||
(change-style style pos (+ pos offset) #f)))
|
||||
(super-new))))
|
||||
(define c (new canvas:color%
|
||||
(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)
|
||||
(on)
|
||||
(off))
|
||||
(preferences:set pref-sym delta))]
|
||||
[check (make-object check-box% name hp c)])
|
||||
check))
|
||||
|
||||
(define slant-check
|
||||
(make-check (string-constant cs-italic)
|
||||
(lambda ()
|
||||
(send delta set-style-on 'slant)
|
||||
(send delta set-style-off 'base))
|
||||
(lambda ()
|
||||
(send delta set-style-on 'base)
|
||||
(send delta set-style-off 'slant))))
|
||||
(define bold-check
|
||||
(make-check (string-constant cs-bold)
|
||||
(lambda ()
|
||||
(send delta set-weight-on 'bold)
|
||||
(send delta set-weight-off 'base))
|
||||
(lambda ()
|
||||
(send delta set-weight-on 'base)
|
||||
(send delta set-weight-off 'bold))))
|
||||
(define underline-check
|
||||
(make-check (string-constant cs-underline)
|
||||
(lambda ()
|
||||
(send delta set-underlined-on #t)
|
||||
(send delta set-underlined-off #f))
|
||||
(lambda ()
|
||||
(send delta set-underlined-off #t)
|
||||
(send delta set-underlined-on #f))))
|
||||
(define color-button
|
||||
(and (>= (get-display-depth) 8)
|
||||
(make-object button%
|
||||
(string-constant cs-change-color)
|
||||
hp
|
||||
(lambda (color-button evt)
|
||||
(let* ([add (send delta get-foreground-add)]
|
||||
[color (make-object color%
|
||||
(send add get-r)
|
||||
(send add get-g)
|
||||
(send add get-b))]
|
||||
[users-choice
|
||||
(get-color-from-user
|
||||
(format sc-choose-color example-text)
|
||||
(send color-button get-top-level-window)
|
||||
color)])
|
||||
(when users-choice
|
||||
(send delta set-delta-foreground users-choice)
|
||||
(preferences:set pref-sym delta)))))))
|
||||
(define style (send (send e get-style-list) find-named-style style-name))
|
||||
|
||||
(send c set-line-count 1)
|
||||
(send c allow-tab-exit #t)
|
||||
|
||||
(send e insert example-text)
|
||||
(send e set-position 0)
|
||||
|
||||
(send slant-check set-value (eq? (send style get-style) 'slant))
|
||||
(send bold-check set-value (eq? (send style get-weight) 'bold))
|
||||
(send underline-check set-value (send style get-underlined)))
|
||||
(define build-color-selection-panel
|
||||
(opt-lambda (parent
|
||||
pref-sym
|
||||
style-name
|
||||
example-text
|
||||
[update-style-delta
|
||||
(lambda (func)
|
||||
(let ([delta (preferences:get pref-sym)])
|
||||
(func delta)
|
||||
(preferences:set pref-sym delta)))])
|
||||
(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)
|
||||
(define/augment (after-insert pos offset)
|
||||
(inner (void) after-insert pos offset)
|
||||
(let ([style (send (get-style-list)
|
||||
find-named-style
|
||||
style-name)])
|
||||
(change-style style pos (+ pos offset) #f)))
|
||||
(super-new))))
|
||||
(define c (new canvas:color%
|
||||
(parent hp)
|
||||
(editor e)
|
||||
(style '(hide-hscroll
|
||||
hide-vscroll))))
|
||||
|
||||
(define (make-check name on off)
|
||||
(let* ([c (lambda (check command)
|
||||
(if (send check get-value)
|
||||
(update-style-delta on)
|
||||
(update-style-delta off)))]
|
||||
[check (make-object check-box% name hp c)])
|
||||
check))
|
||||
|
||||
(define slant-check
|
||||
(make-check (string-constant cs-italic)
|
||||
(lambda (delta)
|
||||
(send delta set-style-on 'slant)
|
||||
(send delta set-style-off 'base))
|
||||
(lambda (delta)
|
||||
(send delta set-style-on 'base)
|
||||
(send delta set-style-off 'slant))))
|
||||
(define bold-check
|
||||
(make-check (string-constant cs-bold)
|
||||
(lambda (delta)
|
||||
(send delta set-weight-on 'bold)
|
||||
(send delta set-weight-off 'base))
|
||||
(lambda (delta)
|
||||
(send delta set-weight-on 'base)
|
||||
(send delta set-weight-off 'bold))))
|
||||
(define underline-check
|
||||
(make-check (string-constant cs-underline)
|
||||
(lambda (delta)
|
||||
(send delta set-underlined-on #t)
|
||||
(send delta set-underlined-off #f))
|
||||
(lambda (delta)
|
||||
(send delta set-underlined-off #t)
|
||||
(send delta set-underlined-on #f))))
|
||||
(define color-button
|
||||
(and (>= (get-display-depth) 8)
|
||||
(make-object button%
|
||||
(string-constant cs-change-color)
|
||||
hp
|
||||
(lambda (color-button evt)
|
||||
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
|
||||
[color (make-object color%
|
||||
(send add get-r)
|
||||
(send add get-g)
|
||||
(send add get-b))]
|
||||
[users-choice
|
||||
(get-color-from-user
|
||||
(format sc-choose-color example-text)
|
||||
(send color-button get-top-level-window)
|
||||
color)])
|
||||
(when users-choice
|
||||
(update-style-delta
|
||||
(lambda (delta)
|
||||
(send delta set-delta-foreground users-choice)))))))))
|
||||
(define style (send (send e get-style-list) find-named-style style-name))
|
||||
|
||||
(send c set-line-count 1)
|
||||
(send c allow-tab-exit #t)
|
||||
|
||||
(send e insert example-text)
|
||||
(send e set-position 0)
|
||||
|
||||
(send slant-check set-value (eq? (send style get-style) 'slant))
|
||||
(send bold-check set-value (eq? (send style get-weight) 'bold))
|
||||
(send underline-check set-value (send style get-underlined))))
|
||||
|
||||
(define (add/mult-set m v)
|
||||
(send m set (car v) (cadr v) (caddr v)))
|
||||
|
|
@ -194,16 +202,60 @@
|
|||
(list (string-constant preferences-colors)
|
||||
(string-constant background-color))
|
||||
(lambda (parent)
|
||||
(add-solid-color-config (string-constant background-color)
|
||||
parent
|
||||
'framework:basic-canvas-background)
|
||||
(build-color-selection-panel parent
|
||||
'framework:default-text-color
|
||||
"Basic"
|
||||
(string-constant default-text-color)))))
|
||||
(let ([vp (new vertical-panel% (parent parent))])
|
||||
(add-solid-color-config (string-constant background-color)
|
||||
vp
|
||||
'framework:basic-canvas-background)
|
||||
(add-solid-color-config (string-constant paren-match-color)
|
||||
vp
|
||||
'framework:paren-match-color)
|
||||
(build-text-foreground-selection-panel vp
|
||||
'framework:default-text-color
|
||||
"Standard"
|
||||
(string-constant default-text-color))))))
|
||||
|
||||
(define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
|
||||
(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)
|
||||
(define/augment (after-insert pos offset)
|
||||
(inner (void) after-insert pos offset)
|
||||
(let ([style (send (get-style-list)
|
||||
find-named-style
|
||||
style-name)])
|
||||
(change-style style pos (+ pos offset) #f)))
|
||||
(super-new))))
|
||||
(define c (new canvas:color%
|
||||
(parent hp)
|
||||
(editor e)
|
||||
(style '(hide-hscroll
|
||||
hide-vscroll))))
|
||||
(define color-button
|
||||
(and (>= (get-display-depth) 8)
|
||||
(make-object button%
|
||||
(string-constant cs-change-color)
|
||||
hp
|
||||
(lambda (color-button evt)
|
||||
(let ([users-choice
|
||||
(get-color-from-user
|
||||
(format sc-choose-color example-text)
|
||||
(send color-button get-top-level-window)
|
||||
(preferences:get pref-sym))])
|
||||
(when users-choice
|
||||
(preferences:set pref-sym users-choice)))))))
|
||||
(define style (send (send e get-style-list) find-named-style style-name))
|
||||
|
||||
(send c set-line-count 1)
|
||||
(send c allow-tab-exit #t)
|
||||
|
||||
(send e insert example-text)
|
||||
(send e set-position 0))
|
||||
|
||||
(define (add-solid-color-config label parent pref-id)
|
||||
(letrec ([panel (new vertical-panel% (parent parent))]
|
||||
(letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))]
|
||||
[hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
|
||||
[msg (new message% (parent hp) (label label))]
|
||||
[canvas
|
||||
|
|
|
|||
|
|
@ -241,9 +241,19 @@
|
|||
(scheme:get-color-prefs-table))
|
||||
(preferences:set-default 'framework:coloring-active #t boolean?)
|
||||
|
||||
(color-prefs:register-color-pref 'framework:default-text-color
|
||||
"Basic"
|
||||
(send the-color-database find-color "black"))
|
||||
(preferences:set-default 'framework:default-text-color
|
||||
(send the-color-database find-color "Black")
|
||||
(lambda (x) (is-a? x color%)))
|
||||
|
||||
(preferences:set-un/marshall 'framework:default-text-color
|
||||
(lambda (c) (list (send c red) (send c green) (send c blue)))
|
||||
(lambda (lst)
|
||||
(make-object color% (car lst) (cadr lst) (caddr lst))))
|
||||
(preferences:add-callback 'framework:default-text-color
|
||||
(lambda (p v)
|
||||
(editor:update-standard-style
|
||||
(lambda (style-delta)
|
||||
(send style-delta set-delta-foreground v)))))
|
||||
|
||||
;; groups
|
||||
|
||||
|
|
|
|||
|
|
@ -604,53 +604,9 @@
|
|||
'framework:paren-match
|
||||
(string-constant flash-paren-match)
|
||||
values values)
|
||||
(scheme-panel-procs scheme-panel)
|
||||
(make-highlight-color-choice scheme-panel))))])
|
||||
(scheme-panel-procs scheme-panel))))])
|
||||
(add-scheme-checkbox-panel)))
|
||||
|
||||
(define (make-highlight-color-choice panel)
|
||||
(let* ([hp (instantiate horizontal-panel% ()
|
||||
(parent panel)
|
||||
(stretchable-height #f))]
|
||||
[msg (make-object message% (string-constant paren-match-color) hp)]
|
||||
[scheme-higlight-canvas (make-object scheme-highlight-canvas% hp)]
|
||||
[button (make-object button%
|
||||
(string-constant choose-color)
|
||||
hp
|
||||
(lambda (x y) (change-highlight-color panel)))])
|
||||
(void)))
|
||||
|
||||
(define scheme-highlight-canvas%
|
||||
(class canvas%
|
||||
(inherit get-client-size get-dc)
|
||||
(define/override (on-paint)
|
||||
(do-draw (get 'framework:paren-match-color)))
|
||||
(define/public (do-draw color)
|
||||
(let ([dc (get-dc)])
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen
|
||||
color
|
||||
1
|
||||
'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush
|
||||
color
|
||||
'solid))
|
||||
(let-values ([(w h) (get-client-size)])
|
||||
(send dc draw-rectangle 0 0 w h))))
|
||||
(super-instantiate ())
|
||||
(inherit stretchable-width min-width)
|
||||
(add-callback
|
||||
'framework:paren-match-color
|
||||
(lambda (p v)
|
||||
(do-draw v)))))
|
||||
|
||||
(define (change-highlight-color parent)
|
||||
(let ([new-color
|
||||
(get-color-from-user (string-constant choose-paren-highlight-color)
|
||||
(send parent get-top-level-window)
|
||||
(get 'framework:paren-match-color))])
|
||||
(when new-color
|
||||
(set 'framework:paren-match-color new-color))))
|
||||
|
||||
(define (add-editor-checkbox-panel)
|
||||
(letrec ([add-editor-checkbox-panel
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -42,7 +42,6 @@
|
|||
[-text<%> text<%>]
|
||||
[-text% text%])
|
||||
|
||||
|
||||
(define text-balanced?
|
||||
(opt-lambda (text [start 0] [in-end #f])
|
||||
(let* ([end (or in-end (send text last-position))]
|
||||
|
|
@ -345,9 +344,6 @@
|
|||
(define (get-wordbreak-map) wordbreak-map)
|
||||
(init-wordbreak-map wordbreak-map)
|
||||
|
||||
(define (get-match-color) (preferences:get 'framework:paren-match-color))
|
||||
(define mismatch-color (make-object color% "PINK"))
|
||||
|
||||
(define matching-parenthesis-style
|
||||
(let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)]
|
||||
[style-list (editor:get-standard-style-list)])
|
||||
|
|
|
|||
|
|
@ -274,7 +274,8 @@
|
|||
(define-signature framework:editor-fun^
|
||||
(get-standard-style-list
|
||||
set-standard-style-list-pref-callbacks
|
||||
set-standard-style-list-delta))
|
||||
set-standard-style-list-delta
|
||||
update-standard-style))
|
||||
(define-signature framework:editor^
|
||||
((open framework:editor-class^)
|
||||
(open framework:editor-fun^)))
|
||||
|
|
@ -510,7 +511,9 @@
|
|||
(register-color-pref
|
||||
add-to-preferences-panel
|
||||
build-color-selection-panel
|
||||
add-background-preferences-panel))
|
||||
add-background-preferences-panel
|
||||
marshall-style
|
||||
unmarshall-style))
|
||||
(define-signature framework:color-prefs^
|
||||
((open framework:color-prefs-class^)
|
||||
(open framework:color-prefs-fun^)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user