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

another strategy for sizing the text in the languages dialog

Browse Source 
svn: r17926
This commit is contained in:
Robby Findler 2010-02-01 16:47:43 +00:00
parent 9664c79320
commit f4cd110b1a
1 changed files with 46 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
collects/drscheme/private/language-configuration.ss
View File

@ -1,20 +1,17 @@
#lang mzscheme #lang scheme/base
(require mzlib/unit (require scheme/unit
mrlib/hierlist mrlib/hierlist
mzlib/class scheme/class
mzlib/contract scheme/contract
mzlib/kw scheme/string
mzlib/string scheme/list
mzlib/struct
"drsig.ss" "drsig.ss"
string-constants string-constants
mred mred
framework framework
mzlib/list
mzlib/etc
mzlib/file
setup/getinfo setup/getinfo
syntax/toplevel) syntax/toplevel
(only-in mzlib/struct make-->vector))
(define original-output (current-output-port)) (define original-output (current-output-port))
(define (printfo . args) (apply fprintf original-output args)) (define (printfo . args) (apply fprintf original-output args))
@ -59,7 +56,7 @@
;; only allows addition on phase2 ;; only allows addition on phase2
;; effect: updates `languages' ;; effect: updates `languages'
(define add-language (define add-language
(opt-lambda (language [front? #f]) (λ (language [front? #f])
(drscheme:tools:only-in-phase 'drscheme:language:add-language 'phase2) (drscheme:tools:only-in-phase 'drscheme:language:add-language 'phase2)
(for-each (for-each
@ -105,7 +102,7 @@
initial-language-position) initial-language-position)
x)) x))
(get-languages)) (get-languages))
(first (get-languages)))]) (list-ref (get-languages) 0))])
(make-language-settings lang (send lang default-settings)))) (make-language-settings lang (send lang default-settings))))
;; type language-settings = (make-language-settings (instanceof language<%>) settings) ;; type language-settings = (make-language-settings (instanceof language<%>) settings)
@ -138,7 +135,7 @@
;; as the defaults in the dialog and the output language setting is the user's choice ;; as the defaults in the dialog and the output language setting is the user's choice
;; todo: when button is clicked, ensure language is selected ;; todo: when button is clicked, ensure language is selected
(define language-dialog (define language-dialog
(opt-lambda (show-welcome? language-settings-to-show [parent #f]) (λ (show-welcome? language-settings-to-show [parent #f])
(define ret-dialog% (define ret-dialog%
(class dialog% (class dialog%
(define/override (on-subwindow-char receiver evt) (define/override (on-subwindow-char receiver evt)
@ -250,7 +247,7 @@
;; as the defaults in the dialog and the output language setting is the user's choice ;; as the defaults in the dialog and the output language setting is the user's choice
;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd.
(define fill-language-dialog (define fill-language-dialog
(opt-lambda (parent show-details-parent language-settings-to-show (λ (parent show-details-parent language-settings-to-show
[re-center #f] [re-center #f]
[ok-handler void]) ; en/disable button, execute it [ok-handler void]) ; en/disable button, execute it
@ -258,8 +255,8 @@
(let ([request-lang-to-show (language-settings-language language-settings-to-show)]) (let ([request-lang-to-show (language-settings-language language-settings-to-show)])
(cond (cond
[(equal? initial-language-position (send request-lang-to-show get-language-position)) [(equal? initial-language-position (send request-lang-to-show get-language-position))
(values (first (get-languages)) (values (list-ref (get-languages) 0)
(send (first (get-languages)) default-settings)) (send (list-ref (get-languages) 0) default-settings))
(values #f #f)] (values #f #f)]
[else (values request-lang-to-show [else (values request-lang-to-show
(language-settings-settings language-settings-to-show))]))) (language-settings-settings language-settings-to-show))])))
@ -390,7 +387,7 @@
[parent in-source-discussion-panel] [parent in-source-discussion-panel]
[stretchable-width #f] [stretchable-width #f]
[min-width 32])) [min-width 32]))
(define stupid-internal-definition-syntax1 (add-discussion in-source-discussion-panel)) (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel))
(define most-recent-languages-hier-list-selection #f) (define most-recent-languages-hier-list-selection #f)
(define use-chosen-language-rb (define use-chosen-language-rb
(new radio-box% (new radio-box%
@ -423,7 +420,7 @@
(define no-details-panel (make-object vertical-panel% details-panel)) (define no-details-panel (make-object vertical-panel% details-panel))
(define languages-table (make-hash-table)) (define languages-table (make-hasheq))
(define languages (get-languages)) (define languages (get-languages))
;; selected-language : (union (instanceof language<%>) #f) ;; selected-language : (union (instanceof language<%>) #f)
@ -631,14 +628,14 @@
[else (let* ([position (car positions)] [else (let* ([position (car positions)]
[number (car numbers)] [number (car numbers)]
[sub-ht/sub-hier-list [sub-ht/sub-hier-list
(hash-table-get (hash-ref
ht ht
(string->symbol position) (string->symbol position)
(λ () (λ ()
(if first? (if first?
(let* ([item (send hier-list new-item number-mixin)] (let* ([item (send hier-list new-item number-mixin)]
[x (list (make-hash-table) hier-list item)]) [x (list (make-hasheq) hier-list item)])
(hash-table-put! ht (string->symbol position) x) (hash-set! ht (string->symbol position) x)
(send item set-number number) (send item set-number number)
(send item set-allow-selection #f) (send item set-allow-selection #f)
(let* ([editor (send item get-editor)] (let* ([editor (send item get-editor)]
@ -653,14 +650,14 @@
(if second-number (if second-number
(compose second-number-mixin number-mixin) (compose second-number-mixin number-mixin)
number-mixin))] number-mixin))]
[x (list (make-hash-table) new-list #f)]) [x (list (make-hasheq) new-list #f)])
(send new-list set-number number) (send new-list set-number number)
(when second-number (when second-number
(send new-list set-second-number second-number)) (send new-list set-second-number second-number))
(send new-list set-allow-selection #t) (send new-list set-allow-selection #t)
(send new-list open) (send new-list open)
(send (send new-list get-editor) insert position) (send (send new-list get-editor) insert position)
(hash-table-put! ht (string->symbol position) x) (hash-set! ht (string->symbol position) x)
x))))]) x))))])
(cond (cond
[first? [first?
@ -907,6 +904,7 @@
(do-construct-details)) (do-construct-details))
(update-show/hide-details) (update-show/hide-details)
(send languages-hier-list focus) (send languages-hier-list focus)
(size-discussion-canvas in-source-discussion-editor-canvas)
(values (values
(λ () selected-language) (λ () selected-language)
(λ () (λ ()
@ -920,10 +918,8 @@
[horizontal-inset 0] [horizontal-inset 0]
[vertical-inset 0] [vertical-inset 0]
[parent p] [parent p]
[style '(no-border auto-vscroll no-hscroll transparent)] [style '(no-border no-vscroll no-hscroll transparent)]
[editor t])]) [editor t])])
(send c set-line-count 3)
(send t set-styles-sticky #f) (send t set-styles-sticky #f)
(send t set-autowrap-bitmap #f) (send t set-autowrap-bitmap #f)
(let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))]
@ -949,37 +945,18 @@
(send t hide-caret #t) (send t hide-caret #t)
(send t auto-wrap #t) (send t auto-wrap #t)
(send t lock #t))) (send t lock #t)
c))
(define panel-background-editor-canvas% (define (size-discussion-canvas canvas)
(class editor-canvas% (let ([t (send canvas get-editor)])
(inherit get-dc get-client-size)
(define/override (on-paint)
(let-values ([(cw ch) (get-client-size)])
(let* ([dc (get-dc)]
[old-pen (send dc get-pen)]
[old-brush (send dc get-brush)])
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(send dc draw-rectangle 0 0 cw ch)
(send dc set-pen old-pen)
(send dc set-brush old-brush)))
(super on-paint))
(super-new)))
(define panel-background-text% (let ([by (box 0)])
(class text% (send t position-location
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (send t line-end-position (send t last-line))
(when before? #f
(let ([old-pen (send dc get-pen)] by)
[old-brush (send dc get-brush)]) (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24)))))
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
(send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
(send dc draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top))
(send dc set-pen old-pen)
(send dc set-brush old-brush)))
(super on-paint before? dc left top right bottom dx dy draw-caret))
(super-new)))
(define section-style-delta (make-object style-delta% 'change-bold)) (define section-style-delta (make-object style-delta% 'change-bold))
(send section-style-delta set-delta-foreground "medium blue") (send section-style-delta set-delta-foreground "medium blue")
@ -1236,7 +1213,7 @@
(format "uncaught exception: ~s" x))) (format "uncaught exception: ~s" x)))
read-syntax/namespace-introduce)]) read-syntax/namespace-introduce)])
(contract (contract
(opt-> () (->* ()
(any/c port?) (any/c port?)
(or/c syntax? eof-object?)) (or/c syntax? eof-object?))
(dynamic-require (dynamic-require
@ -1291,7 +1268,7 @@
(regexp-split #rx"/" str)))) (regexp-split #rx"/" str))))
(define read-syntax/namespace-introduce (define read-syntax/namespace-introduce
(opt-lambda (source-name-v [input-port (current-input-port)]) (λ (source-name-v [input-port (current-input-port)])
(let ([v (read-syntax source-name-v input-port)]) (let ([v (read-syntax source-name-v input-port)])
(if (syntax? v) (if (syntax? v)
(namespace-syntax-introduce v) (namespace-syntax-introduce v)
@ -1417,7 +1394,7 @@
(run-in-user-thread (run-in-user-thread
(λ () (λ ()
(namespace-require 'errortrace/errortrace-key) (namespace-require 'errortrace/errortrace-key)
(namespace-transformer-require 'errortrace/errortrace-key)))) (namespace-require '(for-syntax errortrace/errortrace-key)))))
(super-new))) (super-new)))
(define (r5rs-mixin %) (define (r5rs-mixin %)
@ -1767,13 +1744,12 @@
'normal 'normal
'normal)) 'normal))
(define/kw (get-font #:key (define (get-font #:point-size [point-size (send default-font get-point-size)]
(point-size (send default-font get-point-size)) #:family (family (send default-font get-family))
(family (send default-font get-family)) #:style (style (send default-font get-style))
(style (send default-font get-style)) #:weight (weight (send default-font get-weight))
(weight (send default-font get-weight)) #:underlined (underlined (send default-font get-underlined))
(underlined (send default-font get-underlined)) #:smoothing (smoothing (send default-font get-smoothing)))
(smoothing (send default-font get-smoothing)))
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
point-size point-size
family family
@ -1824,7 +1800,7 @@
(new canvas-message% (parent panel2) (label (string-constant start-with-before))) (new canvas-message% (parent panel2) (label (string-constant start-with-before)))
(new canvas-message% (new canvas-message%
(parent panel2) (parent panel2)
(label (car (last-pair lang))) (label (last lang))
(color (send the-color-database find-color "blue")) (color (send the-color-database find-color "blue"))
(callback (λ () (change-current-lang-to lang))) (callback (λ () (change-current-lang-to lang)))
(font (get-font #:underlined #t))) (font (get-font #:underlined #t)))