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

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

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