Skip to content

Commit 7497abf

Browse files
rfindlerrfindler
committed
use radio-buttons to choose the color scheme in the preferences panel
1 parent 47f6805 commit 7497abf

File tree

3 files changed

+105
-58
lines changed

3 files changed

+105
-58
lines changed

‎gui-lib/framework/private/color-prefs.rkt‎

Lines changed: 99 additions & 56 deletions
Original file line numberDiff line numberDiff line change
@@ -1233,6 +1233,32 @@ on top's background stays in the wrong mode.
12331233
(define init-value (lookup-in-color-scheme name))
12341234
(editor:set-standard-style-list-delta style-name init-value)))
12351235

1236+
(define color-scheme-examples-parents '())
1237+
(define (update-dark-light-preferences-panel-ordering dark-should-be-first?)
1238+
(for ([color-scheme-examples-parent (in-list color-scheme-examples-parents)])
1239+
(define dark-is-first?
1240+
(let loop ([area (car (send color-scheme-examples-parent get-children))])
1241+
(cond
1242+
[(is-a? area message%)
1243+
(equal? (send area get-label) (string-constant dark-color-scheme))]
1244+
[(is-a? area area-container<%>)
1245+
(for/or ([area (in-list (send area get-children))])
1246+
(loop area))]
1247+
[else #f])))
1248+
(unless (equal? dark-should-be-first? dark-is-first?)
1249+
(send color-scheme-examples-parent
1250+
change-children
1251+
reverse))))
1252+
1253+
(preferences:add-callback
1254+
'framework:white-on-black-mode?
1255+
(λ (p v)
1256+
(update-dark-light-preferences-panel-ordering
1257+
(match v
1258+
['platform (white-on-black-panel-scheme?)]
1259+
[#t #t]
1260+
[#f #f]))))
1261+
12361262
(define (add-color-scheme-preferences-panel #:extras [extras void])
12371263
(preferences:add-panel
12381264
(list (string-constant preferences-colors)
@@ -1298,72 +1324,89 @@ on top's background stays in the wrong mode.
12981324
[#t 2]
12991325
[#f 1]))))])
13001326

1301-
(define (setup-color-scheme-choice dark-mode? label pref-sym)
1302-
(define this-mode-color-schemes
1303-
(for/list ([color-scheme (in-list known-color-schemes)]
1304-
#:when (equal? dark-mode? (color-scheme-white-on-black-base? color-scheme)))
1305-
color-scheme))
1306-
(define this-mode-choice
1307-
(new choice%
1308-
[parent top-hp2]
1309-
[label label]
1310-
[choices (for/list ([color-scheme (in-list this-mode-color-schemes)])
1311-
(color-scheme-button-label color-scheme))]
1312-
[callback
1313-
(λ (_1 _2)
1314-
(preferences:set pref-sym
1315-
(color-scheme-name
1316-
(list-ref this-mode-color-schemes
1317-
(send this-mode-choice get-selection)))))]))
1318-
(define (update-choice val)
1319-
(send this-mode-choice set-selection
1320-
(for/or ([i (in-naturals)]
1321-
[color-scheme (in-list this-mode-color-schemes)])
1322-
(and (equal? (color-scheme-name color-scheme) val)
1323-
i))))
1324-
(preferences:add-callback pref-sym (λ (sym val) (update-choice val)))
1325-
(update-choice (preferences:get pref-sym)))
1326-
(setup-color-scheme-choice #f (string-constant light-color-scheme) 'framework:color-scheme-light)
1327-
(setup-color-scheme-choice #t (string-constant dark-color-scheme) 'framework:color-scheme-dark)
1328-
13291327
(define color-scheme-examples-vp
13301328
(new-vertical-panel%
13311329
[spacing 10]
13321330
[border 10]
13331331
[parent vp]))
1334-
(for ([color-scheme (in-list known-color-schemes)])
1335-
(define hp (new-vertical-panel%
1336-
[parent color-scheme-examples-vp]
1337-
[alignment '(center top)]
1338-
[stretchable-height #t]
1339-
[style '(border)]))
1340-
(define t (new racket:text%))
1341-
(define str (color-scheme-example color-scheme))
1342-
(send t insert str)
1343-
(define msg
1344-
(new message%
1345-
[stretchable-width #f]
1346-
[label (color-scheme-button-label color-scheme)]
1347-
[parent hp]))
1348-
(define ec (new editor-canvas%
1349-
[parent hp]
1350-
[style '(no-border auto-hscroll no-vscroll)]
1351-
[editor t]))
1352-
(define (update-colors defaults?)
1332+
(set! color-scheme-examples-parents
1333+
(cons
1334+
color-scheme-examples-vp
1335+
color-scheme-examples-parents))
1336+
(define (mk-color-scheme-radio-buttons white-on-black? radio-panel pref-sym)
1337+
(for ([color-scheme (in-list known-color-schemes)]
1338+
#:when (equal? white-on-black? (color-scheme-white-on-black-base? color-scheme)))
1339+
(define vp (new-vertical-panel%
1340+
[parent radio-panel]
1341+
[alignment '(left top)]
1342+
[stretchable-height #f]))
1343+
(define label (new radio-box%
1344+
[parent vp]
1345+
[label #f]
1346+
[selection
1347+
(if (equal? (preferences:get pref-sym)
1348+
(color-scheme-name color-scheme))
1349+
0
1350+
#f)]
1351+
[callback
1352+
(λ (_1 _2)
1353+
(preferences:set
1354+
pref-sym
1355+
(color-scheme-name color-scheme)))]
1356+
[choices (list (color-scheme-button-label color-scheme))]))
1357+
(preferences:add-callback
1358+
pref-sym
1359+
(λ (p v)
1360+
(send label set-selection
1361+
(if (equal? v (color-scheme-name color-scheme))
1362+
0
1363+
#f))))
1364+
(define t (new racket:text%))
1365+
(define str (color-scheme-example color-scheme))
1366+
(send t insert str)
1367+
(define inner-hp (new-horizontal-panel%
1368+
[parent vp]
1369+
[stretchable-height #f]))
1370+
(define spacer (new panel%
1371+
[parent inner-hp]
1372+
[stretchable-width #f]))
1373+
(send spacer min-width 40)
1374+
(define ec (new editor-canvas%
1375+
[parent inner-hp]
1376+
[style '(no-border auto-hscroll no-vscroll)]
1377+
[editor t]))
1378+
(send ec set-line-count (+ 1 (for/sum ([c (in-string str)])
1379+
(if (equal? c #\newline)
1380+
1
1381+
0))))
13531382
(define bkg-name 'framework:basic-canvas-background)
13541383
(send ec set-canvas-background
13551384
(lookup-in-color-scheme/given-mapping
13561385
bkg-name
1357-
(if defaults?
1358-
(hash)
1359-
(preferences:get (color-scheme-entry-name->pref-name bkg-name)))
1386+
(preferences:get (color-scheme-entry-name->pref-name bkg-name))
13601387
color-scheme))
1361-
(send t set-style-list (color-scheme->style-list color-scheme defaults?)))
1362-
(send ec set-line-count (+ 1 (for/sum ([c (in-string str)])
1363-
(if (equal? c #\newline)
1364-
1
1365-
0))))
1366-
(update-colors #f))
1388+
(send t set-style-list (color-scheme->style-list color-scheme #f))))
1389+
1390+
(define dark-panel (new vertical-panel%
1391+
[parent color-scheme-examples-vp]
1392+
[stretchable-height #f]
1393+
[style '(border)]))
1394+
(define light-panel (new vertical-panel%
1395+
[parent color-scheme-examples-vp]
1396+
[stretchable-height #f]
1397+
[style '(border)]))
1398+
(new message%
1399+
[parent dark-panel]
1400+
[label (string-constant dark-color-scheme)])
1401+
(new message%
1402+
[parent light-panel]
1403+
[label (string-constant light-color-scheme)])
1404+
(mk-color-scheme-radio-buttons #t dark-panel 'framework:color-scheme-dark)
1405+
(mk-color-scheme-radio-buttons #f light-panel 'framework:color-scheme-light)
1406+
1407+
(update-dark-light-preferences-panel-ordering
1408+
(white-on-black-color-scheme?))
1409+
13671410
(define revert-button%
13681411
(new button%
13691412
[label (string-constant revert-colors-to-color-scheme-defaults)]

‎gui-lib/framework/private/main.rkt‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -665,7 +665,10 @@
665665
(or (color-prefs:lookup-color-scheme scheme-name)
666666
(if (white-on-black-panel-scheme?)
667667
(color-prefs:built-in-wob-color-scheme)
668-
(color-prefs:built-in-color-scheme)))))))
668+
(color-prefs:built-in-color-scheme)))))
669+
670+
(color-prefs:update-dark-light-preferences-panel-ordering
671+
(color-prefs:white-on-black-color-scheme?))))
669672

670673
(preferences:add-callback
671674
'framework:color-scheme-light

‎gui-lib/framework/private/sig.rkt‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -392,7 +392,8 @@
392392
(change-colors-to-match-color-scheme
393393
lookup-color-scheme
394394
built-in-wob-color-scheme
395-
built-in-color-scheme))
395+
built-in-color-scheme
396+
update-dark-light-preferences-panel-ordering))
396397

397398
(define-signature racket-class^
398399
(text<%>

0 commit comments

Comments
 (0)