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

.

Browse Source 
original commit: 41b04ef3c618c5a3c35c9e57d73e7aa422418030
This commit is contained in:
Robby Findler 2004-10-07 22:58:34 +00:00
parent 8c72da58aa
commit edf73ab783
6 changed files with 170 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/framework/framework.ss
View File

@ -1327,6 +1327,13 @@
"@flink editor:get-standard-style-list %" "@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 (editor:set-standard-style-list-delta
(string? (is-a?/c style-delta%) . -> . void?) (string? (is-a?/c style-delta%) . -> . void?)
(name delta) (name delta)

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

@ -24,90 +24,98 @@
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
;; constructs a panel containg controls to configure the preferences panel. ;; constructs a panel containg controls to configure the preferences panel.
;; BUG: style changes don't update the check boxes. ;; BUG: style changes don't update the check boxes.
(define (build-color-selection-panel parent pref-sym style-name example-text) (define build-color-selection-panel
(define hp (new horizontal-panel% (opt-lambda (parent
(parent parent) pref-sym
(style '(border)) style-name
(stretchable-height #f))) example-text
(define e (new (class standard-style-list-text% [update-style-delta
(inherit change-style get-style-list) (lambda (func)
(define/augment (after-insert pos offset) (let ([delta (preferences:get pref-sym)])
(inner (void) after-insert pos offset) (func delta)
(let ([style (send (get-style-list) (preferences:set pref-sym delta)))])
find-named-style (define hp (new horizontal-panel%
style-name)]) (parent parent)
(change-style style pos (+ pos offset) #f))) (style '(border))
(super-new)))) (stretchable-height #f)))
(define c (new canvas:color% (define e (new (class standard-style-list-text%
(parent hp) (inherit change-style get-style-list)
(editor e) (define/augment (after-insert pos offset)
(style '(hide-hscroll (inner (void) after-insert pos offset)
hide-vscroll)))) (let ([style (send (get-style-list)
find-named-style
(define delta (preferences:get pref-sym)) style-name)])
(define (make-check name on off) (change-style style pos (+ pos offset) #f)))
(let* ([c (lambda (check command) (super-new))))
(if (send check get-value) (define c (new canvas:color%
(on) (parent hp)
(off)) (editor e)
(preferences:set pref-sym delta))] (style '(hide-hscroll
[check (make-object check-box% name hp c)]) hide-vscroll))))
check))
(define (make-check name on off)
(define slant-check (let* ([c (lambda (check command)
(make-check (string-constant cs-italic) (if (send check get-value)
(lambda () (update-style-delta on)
(send delta set-style-on 'slant) (update-style-delta off)))]
(send delta set-style-off 'base)) [check (make-object check-box% name hp c)])
(lambda () check))
(send delta set-style-on 'base)
(send delta set-style-off 'slant)))) (define slant-check
(define bold-check (make-check (string-constant cs-italic)
(make-check (string-constant cs-bold) (lambda (delta)
(lambda () (send delta set-style-on 'slant)
(send delta set-weight-on 'bold) (send delta set-style-off 'base))
(send delta set-weight-off 'base)) (lambda (delta)
(lambda () (send delta set-style-on 'base)
(send delta set-weight-on 'base) (send delta set-style-off 'slant))))
(send delta set-weight-off 'bold)))) (define bold-check
(define underline-check (make-check (string-constant cs-bold)
(make-check (string-constant cs-underline) (lambda (delta)
(lambda () (send delta set-weight-on 'bold)
(send delta set-underlined-on #t) (send delta set-weight-off 'base))
(send delta set-underlined-off #f)) (lambda (delta)
(lambda () (send delta set-weight-on 'base)
(send delta set-underlined-off #t) (send delta set-weight-off 'bold))))
(send delta set-underlined-on #f)))) (define underline-check
(define color-button (make-check (string-constant cs-underline)
(and (>= (get-display-depth) 8) (lambda (delta)
(make-object button% (send delta set-underlined-on #t)
(string-constant cs-change-color) (send delta set-underlined-off #f))
hp (lambda (delta)
(lambda (color-button evt) (send delta set-underlined-off #t)
(let* ([add (send delta get-foreground-add)] (send delta set-underlined-on #f))))
[color (make-object color% (define color-button
(send add get-r) (and (>= (get-display-depth) 8)
(send add get-g) (make-object button%
(send add get-b))] (string-constant cs-change-color)
[users-choice hp
(get-color-from-user (lambda (color-button evt)
(format sc-choose-color example-text) (let* ([add (send (preferences:get pref-sym) get-foreground-add)]
(send color-button get-top-level-window) [color (make-object color%
color)]) (send add get-r)
(when users-choice (send add get-g)
(send delta set-delta-foreground users-choice) (send add get-b))]
(preferences:set pref-sym delta))))))) [users-choice
(define style (send (send e get-style-list) find-named-style style-name)) (get-color-from-user
(format sc-choose-color example-text)
(send c set-line-count 1) (send color-button get-top-level-window)
(send c allow-tab-exit #t) color)])
(when users-choice
(send e insert example-text) (update-style-delta
(send e set-position 0) (lambda (delta)
(send delta set-delta-foreground users-choice)))))))))
(send slant-check set-value (eq? (send style get-style) 'slant)) (define style (send (send e get-style-list) find-named-style style-name))
(send bold-check set-value (eq? (send style get-weight) 'bold))
(send underline-check set-value (send style get-underlined))) (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) (define (add/mult-set m v)
(send m set (car v) (cadr v) (caddr v))) (send m set (car v) (cadr v) (caddr v)))
@ -194,16 +202,60 @@
(list (string-constant preferences-colors) (list (string-constant preferences-colors)
(string-constant background-color)) (string-constant background-color))
(lambda (parent) (lambda (parent)
(add-solid-color-config (string-constant background-color) (let ([vp (new vertical-panel% (parent parent))])
parent (add-solid-color-config (string-constant background-color)
'framework:basic-canvas-background) vp
(build-color-selection-panel parent 'framework:basic-canvas-background)
'framework:default-text-color (add-solid-color-config (string-constant paren-match-color)
"Basic" vp
(string-constant default-text-color))))) '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) (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))] [hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
[msg (new message% (parent hp) (label label))] [msg (new message% (parent hp) (label label))]
[canvas [canvas

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

@ -241,9 +241,19 @@
(scheme:get-color-prefs-table)) (scheme:get-color-prefs-table))
(preferences:set-default 'framework:coloring-active #t boolean?) (preferences:set-default 'framework:coloring-active #t boolean?)
(color-prefs:register-color-pref 'framework:default-text-color (preferences:set-default 'framework:default-text-color
"Basic" (send the-color-database find-color "Black")
(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 ;; groups

46
collects/framework/private/preferences.ss
View File

@ -604,53 +604,9 @@
'framework:paren-match 'framework:paren-match
(string-constant flash-paren-match) (string-constant flash-paren-match)
values values) values values)
(scheme-panel-procs scheme-panel) (scheme-panel-procs scheme-panel))))])
(make-highlight-color-choice scheme-panel))))])
(add-scheme-checkbox-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) (define (add-editor-checkbox-panel)
(letrec ([add-editor-checkbox-panel (letrec ([add-editor-checkbox-panel
(lambda () (lambda ()

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

@ -42,7 +42,6 @@
[-text<%> text<%>] [-text<%> text<%>]
[-text% text%]) [-text% text%])
(define text-balanced? (define text-balanced?
(opt-lambda (text [start 0] [in-end #f]) (opt-lambda (text [start 0] [in-end #f])
(let* ([end (or in-end (send text last-position))] (let* ([end (or in-end (send text last-position))]
@ -345,9 +344,6 @@
(define (get-wordbreak-map) wordbreak-map) (define (get-wordbreak-map) wordbreak-map)
(init-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 (define matching-parenthesis-style
(let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)] (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)]
[style-list (editor:get-standard-style-list)]) [style-list (editor:get-standard-style-list)])

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

@ -274,7 +274,8 @@
(define-signature framework:editor-fun^ (define-signature framework:editor-fun^
(get-standard-style-list (get-standard-style-list
set-standard-style-list-pref-callbacks set-standard-style-list-pref-callbacks
set-standard-style-list-delta)) set-standard-style-list-delta
update-standard-style))
(define-signature framework:editor^ (define-signature framework:editor^
((open framework:editor-class^) ((open framework:editor-class^)
(open framework:editor-fun^))) (open framework:editor-fun^)))
@ -510,7 +511,9 @@
(register-color-pref (register-color-pref
add-to-preferences-panel add-to-preferences-panel
build-color-selection-panel build-color-selection-panel
add-background-preferences-panel)) add-background-preferences-panel
marshall-style
unmarshall-style))
(define-signature framework:color-prefs^ (define-signature framework:color-prefs^
((open framework:color-prefs-class^) ((open framework:color-prefs-class^)
(open framework:color-prefs-fun^))) (open framework:color-prefs-fun^)))