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

Revise the language dialog to emphasize the teaching

Browse Source 
languages and the 'in the source' language at the expense
of all other dialog-based languages
This commit is contained in:
Robby Findler 2012-10-27 18:38:18 -05:00
parent e1760fa7c0
commit 5768009e3b
5 changed files with 412 additions and 281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

560
collects/drracket/private/language-configuration.rkt
View File

@ -17,7 +17,7 @@
(define original-output (current-output-port)) (define original-output (current-output-port))
(define (oprintf . args) (apply fprintf original-output args)) (define (oprintf . args) (apply fprintf original-output args))
(define-values (sc-use-language-in-source sc-choose-a-language mouse-event-uses-shortcut-prefix?) (define-values (sc-use-language-in-source sc-use-teaching-language sc-choose-a-language mouse-event-uses-shortcut-prefix?)
(let* ([shortcut-prefix (get-default-shortcut-prefix)] (let* ([shortcut-prefix (get-default-shortcut-prefix)]
[menukey-string [menukey-string
(apply string-append (apply string-append
@ -40,8 +40,10 @@
shortcut-prefix)) shortcut-prefix))
(values (string-append (string-constant use-language-in-source) (values (string-append (string-constant use-language-in-source)
(format " (~aU)" menukey-string)) (format " (~aU)" menukey-string))
(string-append (string-constant choose-a-language) (string-append (string-constant teaching-languages)
(format " (~aC)" menukey-string)) (format " (~aT)" menukey-string))
(string-append (string-constant other-languages)
(format " (~aO)" menukey-string))
mouse-event-uses-shortcut-prefix?))) mouse-event-uses-shortcut-prefix?)))
(define sc-lang-in-source-discussion (string-constant lang-in-source-discussion)) (define sc-lang-in-source-discussion (string-constant lang-in-source-discussion))
@ -257,7 +259,7 @@
(add-welcome dialog welcome-before-panel welcome-after-panel)) (add-welcome dialog welcome-before-panel welcome-after-panel))
(send dialog stretchable-width #f) (send dialog stretchable-width #f)
(send dialog stretchable-height #t) (send dialog stretchable-height #f)
(unless parent (unless parent
(send dialog center 'both)) (send dialog center 'both))
@ -276,8 +278,8 @@
;; 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
(λ (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
(define-values (language-to-show settings-to-show) (define-values (language-to-show settings-to-show)
(let ([request-lang-to-show (language-settings-language language-settings-to-show)]) (let ([request-lang-to-show (language-settings-language language-settings-to-show)])
@ -376,9 +378,13 @@
(cond (cond
[(and i (is-a? i hieritem-language<%>)) [(and i (is-a? i hieritem-language<%>))
(define pos (send (send i get-language) get-language-position)) (define pos (send (send i get-language) get-language-position))
(preferences:set 'drracket:language-dialog:hierlist-default pos) (if (eq? this teaching-languages-hier-list)
(set! most-recent-languages-hier-list-selection pos) (preferences:set 'drracket:language-dialog:teaching-hierlist-default pos)
(something-selected i)] (preferences:set 'drracket:language-dialog:hierlist-default pos))
(if (eq? this teaching-languages-hier-list)
(set! most-recent-teaching-languages-hier-list-selection pos)
(set! most-recent-languages-hier-list-selection pos))
(something-selected this i)]
[else [else
(non-language-selected)])) (non-language-selected)]))
;; this is used only because we set `on-click-always' ;; this is used only because we set `on-click-always'
@ -388,7 +394,7 @@
;; double-click selects a language ;; double-click selects a language
(define/override (on-double-select i) (define/override (on-double-select i)
(when (and i (is-a? i hieritem-language<%>)) (when (and i (is-a? i hieritem-language<%>))
(something-selected i) (something-selected this i)
(ok-handler 'execute))) (ok-handler 'execute)))
(super-new [parent parent]) (super-new [parent parent])
;; do this so we can expand/collapse languages on a single click ;; do this so we can expand/collapse languages on a single click
@ -396,9 +402,12 @@
(on-click-always #t) (on-click-always #t)
(allow-deselect #t))) (allow-deselect #t)))
(define outermost-panel (new horizontal-pane% [parent parent])) (define outermost-panel (new horizontal-panel%
[parent parent]
[alignment '(left top)]))
(define languages-choice-panel (new vertical-panel% (define languages-choice-panel (new vertical-panel%
[parent outermost-panel] [parent outermost-panel]
[stretchable-height #f]
[alignment '(left top)])) [alignment '(left top)]))
(define use-language-in-source-rb (define use-language-in-source-rb
@ -411,7 +420,8 @@
(use-language-in-source-rb-callback))])) (use-language-in-source-rb-callback))]))
(define (use-language-in-source-rb-callback) (define (use-language-in-source-rb-callback)
(module-language-selected) (module-language-selected)
(send use-chosen-language-rb set-selection #f)) (send use-chosen-language-rb set-selection #f)
(send use-teaching-language-rb set-selection #f))
(define in-source-discussion-panel (new horizontal-panel% (define in-source-discussion-panel (new horizontal-panel%
[parent languages-choice-panel] [parent languages-choice-panel]
[stretchable-height #f])) [stretchable-height #f]))
@ -421,6 +431,39 @@
[min-width 32])) [min-width 32]))
(define in-source-discussion-editor-canvas (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 (preferences:get 'drracket:language-dialog:hierlist-default)) (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default))
(define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default))
(define use-teaching-language-rb
(new radio-box%
[label #f]
[choices (list sc-use-teaching-language)]
[parent languages-choice-panel]
[callback
(λ (rb evt)
(use-teaching-language-rb-callback))]))
(define (use-teaching-language-rb-callback)
(when most-recent-teaching-languages-hier-list-selection
(select-a-language-in-hierlist teaching-languages-hier-list
(cdr most-recent-teaching-languages-hier-list-selection)))
(send use-chosen-language-rb set-selection #f)
(send use-language-in-source-rb set-selection #f)
(send use-teaching-language-rb set-selection 0)
(send other-languages-hier-list select #f)
(send teaching-languages-hier-list focus))
(define teaching-languages-hier-list-panel
(new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f]))
(define teaching-languages-hier-list-spacer
(new horizontal-panel%
[parent teaching-languages-hier-list-panel]
[stretchable-width #f]
[min-width 16]))
(define teaching-languages-hier-list
(new selectable-hierlist%
[parent teaching-languages-hier-list-panel]
[style '(no-border no-hscroll auto-vscroll transparent)]))
(define use-chosen-language-rb (define use-chosen-language-rb
(new radio-box% (new radio-box%
[label #f] [label #f]
@ -430,19 +473,35 @@
(λ (this-rb evt) (λ (this-rb evt)
(use-chosen-language-rb-callback))])) (use-chosen-language-rb-callback))]))
(define (use-chosen-language-rb-callback) (define (use-chosen-language-rb-callback)
(when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children))
(send languages-hier-list-panel change-children
(λ (l)
(list languages-hier-list-spacer other-languages-hier-list))))
(when most-recent-languages-hier-list-selection (when most-recent-languages-hier-list-selection
(select-a-language-in-hierlist most-recent-languages-hier-list-selection)) (select-a-language-in-hierlist other-languages-hier-list
most-recent-languages-hier-list-selection))
(send use-language-in-source-rb set-selection #f) (send use-language-in-source-rb set-selection #f)
(send languages-hier-list focus)) (send use-teaching-language-rb set-selection #f)
(define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) (send teaching-languages-hier-list select #f)
(send other-languages-hier-list focus))
(define languages-hier-list-panel (new horizontal-panel%
[parent languages-choice-panel]
[stretchable-height #f]))
(define ellipsis-spacer-panel (new horizontal-panel%
[parent languages-hier-list-panel]
[stretchable-width #f]
[min-width 32]))
(define ellipsis-message (new message% [label "..."] [parent languages-hier-list-panel]))
(define languages-hier-list-spacer (new horizontal-panel% (define languages-hier-list-spacer (new horizontal-panel%
[parent languages-hier-list-panel] [parent languages-hier-list-panel]
[stretchable-width #f] [stretchable-width #f]
[min-width 16])) [min-width 16]))
(define languages-hier-list (new selectable-hierlist% (define other-languages-hier-list (new selectable-hierlist%
[parent languages-hier-list-panel] [parent languages-hier-list-panel]
[style '(no-border no-hscroll auto-vscroll transparent)])) [style '(no-border no-hscroll auto-vscroll transparent)]))
(define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details-outer-panel (make-object vertical-pane% outermost-panel))
(define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
(define details-panel (make-object panel:single% details/manual-parent-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel))
@ -493,9 +552,11 @@
(define (module-language-selected) (define (module-language-selected)
;; need to deselect things in the languages-hier-list at this point. ;; need to deselect things in the languages-hier-list at this point.
(send languages-hier-list select #f) (send other-languages-hier-list select #f)
(send use-chosen-language-rb set-selection #f) (send teaching-languages-hier-list select #f)
(send use-language-in-source-rb set-selection 0) (send use-language-in-source-rb set-selection 0)
(send use-chosen-language-rb set-selection #f)
(send use-teaching-language-rb set-selection #f)
(ok-handler 'enable) (ok-handler 'enable)
(send details-button enable #t) (send details-button enable #t)
(update-gui-based-on-selected-language module-language*language (update-gui-based-on-selected-language module-language*language
@ -504,12 +565,14 @@
;; no-language-selected : -> void ;; no-language-selected : -> void
;; updates the GUI for the situation where no language at all selected, and ;; updates the GUI for the situation where no language at all selected, and
;; and thus neither of the radio buttons should be selected. ;; and thus none of the radio buttons should be selected.
;; this generally happens when there is no preference setting for the language ;; this generally happens when there is no preference setting for the language
;; (ie the user has just started drracket for the first time) ;; (ie the user has just started drracket for the first time)
(define (no-language-selected) (define (no-language-selected)
(non-language-selected) (non-language-selected)
(send use-chosen-language-rb set-selection #f)) (send use-language-in-source-rb set-selection #f)
(send use-chosen-language-rb set-selection #f)
(send use-teaching-language-rb set-selection #f))
(define module-language*language 'module-language*-not-yet-set) (define module-language*language 'module-language*-not-yet-set)
(define module-language*get-language-details-panel 'module-language*-not-yet-set) (define module-language*get-language-details-panel 'module-language*-not-yet-set)
@ -519,8 +582,6 @@
;; updates the GUI and selected-language and get/set-selected-language-settings ;; updates the GUI and selected-language and get/set-selected-language-settings
;; for when some non-language is selected in the hierlist ;; for when some non-language is selected in the hierlist
(define (non-language-selected) (define (non-language-selected)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(send revert-to-defaults-button enable #f) (send revert-to-defaults-button enable #f)
(send details-panel active-child no-details-panel) (send details-panel active-child no-details-panel)
(send one-line-summary-message set-label "") (send one-line-summary-message set-label "")
@ -530,9 +591,17 @@
(send details-button enable #f)) (send details-button enable #f))
;; something-selected : item -> void ;; something-selected : item -> void
(define (something-selected item) (define (something-selected hierlist item)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f) (send use-language-in-source-rb set-selection #f)
(cond
[(eq? hierlist other-languages-hier-list)
(send use-teaching-language-rb set-selection #f)
(send use-chosen-language-rb set-selection 0)
(send teaching-languages-hier-list select #f)]
[else
(send use-teaching-language-rb set-selection 0)
(send use-chosen-language-rb set-selection #f)
(send other-languages-hier-list select #f)])
(ok-handler 'enable) (ok-handler 'enable)
(send details-button enable #t) (send details-button enable #t)
(send item selected)) (send item selected))
@ -546,34 +615,38 @@
;; when `language' matches language-to-show, update the settings ;; when `language' matches language-to-show, update the settings
;; panel to match language-to-show, otherwise set to defaults. ;; panel to match language-to-show, otherwise set to defaults.
(define (add-language-to-dialog language) (define (add-language-to-dialog language)
(let ([positions (send language get-language-position)] (define positions (send language get-language-position))
[numbers (send language get-language-numbers)]) (define numbers (send language get-language-numbers))
(define teaching-language? (and (pair? positions)
(equal? (car positions)
(string-constant teaching-languages))))
;; don't show the initial language ... ;; don't show the initial language ...
(unless (equal? positions initial-language-position) (unless (equal? positions initial-language-position)
(unless (and (list? positions) (unless (and (list? positions)
(list? numbers) (list? numbers)
(pair? positions) (pair? positions)
(pair? numbers) (pair? numbers)
(andmap number? numbers) (andmap number? numbers)
(andmap string? positions) (andmap string? positions)
(= (length positions) (length numbers)) (= (length positions) (length numbers))
((length numbers) . >= . 1)) ((length numbers) . >= . 1))
(error 'drracket:language
(string-append
"languages position and numbers must be lists of strings and numbers,"
" respectively, must have the same length, and must each contain at"
" least one element, got: ~e ~e")
positions numbers))
(when (null? (cdr positions))
(unless (equal? positions (list (string-constant module-language-name)))
(error 'drracket:language (error 'drracket:language
(string-append "Only the module language may be at the top level. Other languages must have at least two levels")))
"languages position and numbers must be lists of strings and numbers,"
" respectively, must have the same length, and must each contain at"
" least one element, got: ~e ~e")
positions numbers))
(when (null? (cdr positions)) (send other-languages-hier-list clear-fringe-cache)
(unless (equal? positions (list (string-constant module-language-name))) (send teaching-languages-hier-list clear-fringe-cache)
(error 'drracket:language
"Only the module language may be at the top level. Other languages must have at least two levels")))
(send languages-hier-list clear-fringe-cache) #|
#|
inline the first level of the tree into just items in the hierlist inline the first level of the tree into just items in the hierlist
keep track of the starting (see call to sort method below) by keep track of the starting (see call to sort method below) by
@ -581,67 +654,72 @@
what the sorting number is for its level above (in the second-number mixin) what the sorting number is for its level above (in the second-number mixin)
|# |#
(let add-sub-language ([ht languages-table]
[hier-list (if teaching-language?
teaching-languages-hier-list
other-languages-hier-list)]
[positions (if teaching-language?
(cdr positions)
positions)]
[numbers (if teaching-language?
(cdr numbers)
numbers)]
[first? #t]
[second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number
(cond
[(null? (cdr positions))
(let* ([language-details-panel #f]
[real-get/set-settings
(case-lambda
[()
(cond
[(and language-to-show
settings-to-show
(equal? (send language-to-show get-language-position)
(send language get-language-position)))
settings-to-show]
[else
(send language default-settings)])]
[(x) (void)])]
[get-language-details-panel (lambda () language-details-panel)]
[get/set-settings (lambda x (apply real-get/set-settings x))]
[position (car positions)]
[number (car numbers)])
(let add-sub-language ([ht languages-table] (set! construct-details
[hier-list languages-hier-list] (let ([old construct-details])
[positions positions] (lambda ()
[numbers numbers] (old)
[first? #t] (let-values ([(language-details-panel-real get/set-settings)
[second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number (make-details-panel language)])
(cond (set! language-details-panel language-details-panel-real)
[(null? (cdr positions)) (set! real-get/set-settings get/set-settings))
(let* ([language-details-panel #f]
[real-get/set-settings
(case-lambda
[()
(cond
[(and language-to-show
settings-to-show
(equal? (send language-to-show get-language-position)
(send language get-language-position)))
settings-to-show]
[else
(send language default-settings)])]
[(x) (void)])]
[get-language-details-panel (lambda () language-details-panel)]
[get/set-settings (lambda x (apply real-get/set-settings x))]
[position (car positions)]
[number (car numbers)])
(set! construct-details (let-values ([(vis-lang vis-settings)
(let ([old construct-details]) (cond
(lambda () [(and (not selected-language)
(old) (eq? language-to-show language))
(let-values ([(language-details-panel-real get/set-settings) (values language-to-show settings-to-show)]
(make-details-panel language)]) [(eq? selected-language language)
(set! language-details-panel language-details-panel-real) (values language
(set! real-get/set-settings get/set-settings)) (if (eq? language language-to-show)
settings-to-show
(send language default-settings)))]
[else (values #f #f)])])
(cond
[(and vis-lang
(equal? (send vis-lang get-language-position)
(send language get-language-position)))
(get/set-settings vis-settings)
(send details-panel active-child language-details-panel)]
[else
(get/set-settings (send language default-settings))])))))
(let-values ([(vis-lang vis-settings) (cond
(cond [(equal? positions (list (string-constant module-language-name)))
[(and (not selected-language) (set! module-language*language language)
(eq? language-to-show language)) (set! module-language*get-language-details-panel get-language-details-panel)
(values language-to-show settings-to-show)] (set! module-language*get/set-settings get/set-settings)]
[(eq? selected-language language)
(values language
(if (eq? language language-to-show)
settings-to-show
(send language default-settings)))]
[else (values #f #f)])])
(cond
[(and vis-lang
(equal? (send vis-lang get-language-position)
(send language get-language-position)))
(get/set-settings vis-settings)
(send details-panel active-child language-details-panel)]
[else
(get/set-settings (send language default-settings))])))))
(cond
[(equal? positions (list (string-constant module-language-name)))
(set! module-language*language language)
(set! module-language*get-language-details-panel get-language-details-panel)
(set! module-language*get/set-settings get/set-settings)]
[else [else
(let* ([mixin (compose (let* ([mixin (compose
number-mixin number-mixin
@ -671,61 +749,62 @@
(send language get-style-delta) (send language get-style-delta)
0 0
(send text last-position))])))]))] (send text last-position))])))]))]
[else (let* ([position (car positions)] [else
[number (car numbers)] (let* ([position (car positions)]
[sub-ht/sub-hier-list [number (car numbers)]
(hash-ref [sub-ht/sub-hier-list
ht (hash-ref
(string->symbol position) ht
(λ () (string->symbol position)
(if first? (λ ()
(let* ([item (send hier-list new-item number-mixin)] (if first?
[x (list (make-hasheq) hier-list item)]) (let* ([item (send hier-list new-item number-mixin)]
(hash-set! ht (string->symbol position) x) [x (list (make-hasheq) hier-list item)])
(send item set-number number) (hash-set! ht (string->symbol position) x)
(send item set-allow-selection #f) (send item set-number number)
(let* ([editor (send item get-editor)] (send item set-allow-selection #f)
[pos (send editor last-position)]) (let* ([editor (send item get-editor)]
(send editor insert "\n") [pos (send editor last-position)])
(send editor insert position) (send editor insert "\n")
(send editor change-style small-size-delta pos (+ pos 1)) (send editor insert position)
(send editor change-style section-style-delta (send editor change-style small-size-delta pos (+ pos 1))
(+ pos 1) (send editor last-position))) (send editor change-style section-style-delta
x) (+ pos 1) (send editor last-position)))
(let* ([new-list (send hier-list new-list x)
(if second-number (let* ([new-list (send hier-list new-list
(compose second-number-mixin number-mixin) (if second-number
number-mixin))] (compose second-number-mixin number-mixin)
[x (list (make-hasheq) new-list #f)]) number-mixin))]
(send new-list set-number number) [x (list (make-hasheq) new-list #f)])
(when second-number (send new-list set-number number)
(send new-list set-second-number second-number)) (when second-number
(send new-list set-allow-selection #t) (send new-list set-second-number second-number))
(send new-list open) (send new-list set-allow-selection #t)
(send (send new-list get-editor) insert position) (send new-list open)
(hash-set! ht (string->symbol position) x) (send (send new-list get-editor) insert position)
x))))]) (hash-set! ht (string->symbol position) x)
(cond x))))])
[first? (cond
(unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) [first?
(error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" (unless (= number (send (caddr sub-ht/sub-hier-list) get-number))
(send language get-language-name) (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
position (send language get-language-name)
(send (caddr sub-ht/sub-hier-list) get-number) position
number))] (send (caddr sub-ht/sub-hier-list) get-number)
[else number))]
(unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) [else
(error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" (unless (= number (send (cadr sub-ht/sub-hier-list) get-number))
(send language get-language-name) (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
position (send language get-language-name)
(send (cadr sub-ht/sub-hier-list) get-number) position
number))]) (send (cadr sub-ht/sub-hier-list) get-number)
(add-sub-language (car sub-ht/sub-hier-list) number))])
(cadr sub-ht/sub-hier-list) (add-sub-language (car sub-ht/sub-hier-list)
(cdr positions) (cadr sub-ht/sub-hier-list)
(cdr numbers) (cdr positions)
#f (cdr numbers)
(if first? number #f)))]))))) #f
(if first? number #f)))]))))
(define number<%> (define number<%>
(interface () (interface ()
@ -779,35 +858,59 @@
(send item close) (send item close)
(close-children item)] (close-children item)]
[else (void)])) [else (void)]))
(close-children languages-hier-list)) (close-children other-languages-hier-list)
(close-children teaching-languages-hier-list))
;; open-current-language : -> void ;; open-current-language : -> void
;; opens the tabs that lead to the current language ;; opens the tabs that lead to the current language
;; and selects the current language ;; and selects the current language
(define (open-current-language) (define (open-current-language)
;; set the initial selection in the hierlists
(let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
(when hier-default
(select-a-language-in-hierlist other-languages-hier-list hier-default)))
(let ([hier-default (preferences:get 'drracket:language-dialog:teaching-hierlist-default)])
(when hier-default
(select-a-language-in-hierlist teaching-languages-hier-list (cdr hier-default))))
(send languages-hier-list-panel change-children
(λ (l)
(list ellipsis-spacer-panel ellipsis-message)))
(cond (cond
[(not (and language-to-show settings-to-show)) [(not (and language-to-show settings-to-show))
(no-language-selected)] (no-language-selected)]
[(is-a? language-to-show drracket:module-language:module-language<%>) [(is-a? language-to-show drracket:module-language:module-language<%>)
(let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
(when hier-default
(select-a-language-in-hierlist hier-default)))
;; the above changes the radio button selections, so do it before calling module-language-selected ;; the above changes the radio button selections, so do it before calling module-language-selected
(module-language-selected)] (module-language-selected)]
[else [else
(send languages-hier-list focus) ;; only focus when the module language isn't selected (define position (send language-to-show get-language-position))
(send use-chosen-language-rb set-selection 0) (cond
(send use-language-in-source-rb set-selection #f) [(and (pair? position)
(select-a-language-in-hierlist (send language-to-show get-language-position))])) (equal? (car position)
(string-constant teaching-languages)))
(select-a-language-in-hierlist teaching-languages-hier-list (cdr position))
(send use-teaching-language-rb set-selection 0)
(send use-chosen-language-rb set-selection #f)
(send teaching-languages-hier-list focus)]
[else
(send languages-hier-list-panel change-children
(λ (l)
(list languages-hier-list-spacer other-languages-hier-list)))
(select-a-language-in-hierlist other-languages-hier-list position)
(send use-teaching-language-rb set-selection #f)
(send use-chosen-language-rb set-selection 0)
(send other-languages-hier-list focus)])
(send use-language-in-source-rb set-selection #f)]))
(define (select-a-language-in-hierlist language-position) (define (select-a-language-in-hierlist hier-list language-position)
(cond (cond
[(null? (cdr language-position)) [(null? (cdr language-position))
;; nothing to open here ;; nothing to open here
(send (car (send languages-hier-list get-items)) select #t) (send (car (send hier-list get-items)) select #t)]
(void)]
[else [else
(let loop ([hi languages-hier-list] (let loop ([hi hier-list]
;; skip the first position, since it is flattened into the dialog ;; skip the first position, since it is flattened into the dialog
[first-pos (cadr language-position)] [first-pos (cadr language-position)]
@ -819,8 +922,6 @@
(send hi get-items))]) (send hi get-items))])
(cond (cond
[(null? matching-children) [(null? matching-children)
;; just give up here. probably this means that a bad preference was saved
;; and we're being called from the module-language case in 'open-current-language'
(void)] (void)]
[else [else
(let ([child (car matching-children)]) (let ([child (car matching-children)])
@ -828,8 +929,9 @@
[(null? position) [(null? position)
(send child select #t)] (send child select #t)]
[else [else
(send child open) (when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad
(loop child (car position) (cdr position))]))])))])) (send child open)
(loop child (car position) (cdr position)))]))])))]))
;; docs-callback : -> void ;; docs-callback : -> void
(define (docs-callback) (define (docs-callback)
@ -901,46 +1003,47 @@
(send revert-to-defaults-outer-panel stretchable-width #f) (send revert-to-defaults-outer-panel stretchable-width #f)
(send revert-to-defaults-outer-panel stretchable-height #f) (send revert-to-defaults-outer-panel stretchable-height #f)
(send outermost-panel set-alignment 'center 'center)
(for-each add-language-to-dialog languages) (for-each add-language-to-dialog languages)
(send languages-hier-list sort (define (hier-list-sort-predicate x y)
(λ (x y) (cond
(cond [(and (x . is-a? . second-number<%>)
[(and (x . is-a? . second-number<%>) (y . is-a? . second-number<%>))
(y . is-a? . second-number<%>)) (cond
(cond [(= (send x get-second-number)
[(= (send x get-second-number) (send y get-second-number))
(send y get-second-number)) (< (send x get-number) (send y get-number))]
(< (send x get-number) (send y get-number))] [else
[else (< (send x get-second-number)
(< (send x get-second-number) (send y get-second-number))])]
(send y get-second-number))])] [(and (x . is-a? . number<%>)
[(and (x . is-a? . number<%>) (y . is-a? . second-number<%>))
(y . is-a? . second-number<%>)) (cond
(cond [(= (send x get-number)
[(= (send x get-number) (send y get-second-number))
(send y get-second-number)) #t]
#t] [else
[else (< (send x get-number)
(< (send x get-number) (send y get-second-number))])]
(send y get-second-number))])] [(and (x . is-a? . second-number<%>)
[(and (x . is-a? . second-number<%>) (y . is-a? . number<%>))
(y . is-a? . number<%>)) (cond
(cond [(= (send x get-second-number)
[(= (send x get-second-number) (send y get-number))
(send y get-number)) #f]
#f] [else (< (send x get-second-number)
[else (< (send x get-second-number) (send y get-number))])]
(send y get-number))])] [(and (x . is-a? . number<%>)
[(and (x . is-a? . number<%>) (y . is-a? . number<%>))
(y . is-a? . number<%>)) (< (send x get-number) (send y get-number))]
(< (send x get-number) (send y get-number))] [else #f]))
[else #f]))) (send other-languages-hier-list sort hier-list-sort-predicate)
(send teaching-languages-hier-list sort hier-list-sort-predicate)
;; remove the newline at the front of the first inlined category (if there) ;; remove the newline at the front of the first inlined category (if there)
;; it won't be there if the module language is at the top. ;; it won't be there if the module language is at the top.
(let ([t (send (car (send languages-hier-list get-items)) get-editor)]) (for ([hier-list (in-list (list other-languages-hier-list teaching-languages-hier-list))])
(define t (send (car (send hier-list get-items)) get-editor))
(when (equal? "\n" (send t get-text 0 1)) (when (equal? "\n" (send t get-text 0 1))
(send t delete 0 1))) (send t delete 0 1)))
@ -949,15 +1052,21 @@
(λ (l) (λ (l)
(list details-panel))) (list details-panel)))
(send languages-hier-list stretchable-width #t) (define (config-hier-list hier-list)
(send languages-hier-list stretchable-height #t) (send hier-list stretchable-width #t)
(send languages-hier-list accept-tab-focus #t) (send hier-list stretchable-height #t)
(send languages-hier-list allow-tab-exit #t) (send hier-list accept-tab-focus #t)
(send hier-list allow-tab-exit #t))
(config-hier-list other-languages-hier-list)
(config-hier-list teaching-languages-hier-list)
(send parent reflow-container) (send parent reflow-container)
(close-all-languages) (close-all-languages)
(open-current-language) (open-current-language)
(send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor))) (define (set-min-sizes hier-list)
(send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor))) (send hier-list min-client-width (text-width (send hier-list get-editor)))
(send hier-list min-client-height (text-height (send hier-list get-editor))))
(set-min-sizes other-languages-hier-list)
(set-min-sizes teaching-languages-hier-list)
(when details-shown? (when details-shown?
(do-construct-details)) (do-construct-details))
(update-show/hide-details) (update-show/hide-details)
@ -979,7 +1088,14 @@
(use-language-in-source-rb-callback) (use-language-in-source-rb-callback)
#t) #t)
#f)] #f)]
[(#\c) [(#\t)
(if (mouse-event-uses-shortcut-prefix? evt)
(begin
(send use-teaching-language-rb set-selection 0)
(use-teaching-language-rb-callback)
#t)
#f)]
[(#\o)
(if (mouse-event-uses-shortcut-prefix? evt) (if (mouse-event-uses-shortcut-prefix? evt)
(begin (begin
(send use-chosen-language-rb set-selection 0) (send use-chosen-language-rb set-selection 0)
@ -1178,7 +1294,7 @@
#f #f
#f #f
#t) #t)
(+ 10 ;; upper bound on some platform specific space I don't know how to get. (+ 16 ;; upper bound on some space I don't know how to get.
(floor (inexact->exact (unbox y-box)))))) (floor (inexact->exact (unbox y-box))))))

1
collects/drracket/private/main.rkt
View File

@ -72,6 +72,7 @@
(preferences:set-default 'drracket:defs/ints-labels #t boolean?) (preferences:set-default 'drracket:defs/ints-labels #t boolean?)
(drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) (drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
(drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution)))) (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution))))
(drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket)))) (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket))))

9
collects/scribblings/tools/tools.scrbl
View File

@ -10,7 +10,8 @@
(for-label racket/base racket/gui) (for-label racket/base racket/gui)
(for-label framework/framework) (for-label framework/framework)
(for-label drracket/syncheck-drracket-button (for-label drracket/syncheck-drracket-button
drracket/check-syntax) drracket/check-syntax
string-constants/string-constant)
scribble/eval scribble/eval
scribble/extract) scribble/extract)
@ -318,6 +319,12 @@ This must be bound to a
corresponds to the position of the language in language corresponds to the position of the language in language
dialog. Each language position is a list of strings whose dialog. Each language position is a list of strings whose
length must be at least two. length must be at least two.
If the first string is the same as
@racket[(string-constant teaching-languages)], then
it is put into the ``Teaching Languages'' section
of the dialog. Otherwise, it goes into the ``Other Languages''
section of the dialog.
} }
@item/cap[drscheme-language-numbers]{ @item/cap[drscheme-language-numbers]{
This is optional. If This is optional. If

3
collects/string-constants/private/english-string-constants.rkt
View File

@ -1153,9 +1153,10 @@ please adhere to these guidelines:
(experimental-languages "Experimental Languages") (experimental-languages "Experimental Languages")
(initial-language-category "Initial language") (initial-language-category "Initial language")
(no-language-chosen "No language chosen") (no-language-chosen "No language chosen")
(other-languages "Other Languages")
(module-language-name "Determine language from source") (module-language-name "Determine language from source")
(module-language-one-line-summary "Reads the #lang line to specify the actual language") (module-language-one-line-summary "The #lang line specifies the actual language")
(module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language (module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language
;; for the upper portion of the language dialog ;; for the upper portion of the language dialog

100
collects/tests/drracket/private/drracket-test-util.rkt
View File

@ -353,21 +353,25 @@
(not-on-eventspace-handler-thread 'set-language-level!) (not-on-eventspace-handler-thread 'set-language-level!)
(let ([drs-frame (fw:test:get-active-top-level-window)]) (let ([drs-frame (fw:test:get-active-top-level-window)])
(fw:test:menu-select "Language" "Choose Language...") (fw:test:menu-select "Language" "Choose Language...")
(let* ([language-dialog (wait-for-new-frame drs-frame)] (define language-dialog (wait-for-new-frame drs-frame))
[language-choice (find-labelled-window #f hierarchical-list% (fw:test:get-active-top-level-window))] (fw:test:set-radio-box-item! #rx"Other Languages")
[b1 (box 0)] (define language-choices (find-labelled-windows #f hierarchical-list% (fw:test:get-active-top-level-window)))
[b2 (box 0)] (define b1 (box 0))
[click-on-snip (define b2 (box 0))
(lambda (snip) (define (click-on-snip snip)
(let* ([editor (send (send snip get-admin) get-editor)] (let* ([editor (send (send snip get-admin) get-editor)]
[between-threshold (send editor get-between-threshold)]) [between-threshold (send editor get-between-threshold)])
(send editor get-snip-location snip b1 b2) (send editor get-snip-location snip b1 b2)
(let-values ([(gx gy) (send editor editor-location-to-dc-location (let-values ([(gx gy) (send editor editor-location-to-dc-location
(unbox b1) (unbox b1)
(unbox b2))]) (unbox b2))])
(let ([x (inexact->exact (floor (+ gx between-threshold 1)))] (let ([x (inexact->exact (floor (+ gx between-threshold 1)))]
[y (inexact->exact (floor (+ gy between-threshold 1)))]) [y (inexact->exact (floor (+ gy between-threshold 1)))])
(fw:test:mouse-click 'left x y)))))]) (fw:test:mouse-click 'left x y)))))
(define found-language? #f)
(for ([language-choice (in-list language-choices)])
(send language-choice focus) (send language-choice focus)
(let loop ([list-item language-choice] (let loop ([list-item language-choice]
[language-spec in-language-spec]) [language-spec in-language-spec])
@ -382,41 +386,43 @@
(and matches (and matches
child))) child)))
(send list-item get-items))]) (send list-item get-items))])
(when (null? which) (unless (null? which)
(error 'set-language-level! "couldn't find language: ~e, no match at ~e, poss: ~s" (unless (= 1 (length which))
in-language-spec name (map (λ (child) (send (send child get-editor) get-text)) (error 'set-language-level! "couldn't find language: ~e, double match ~e"
(send list-item get-items)))) in-language-spec name))
(unless (= 1 (length which)) (let ([next-item (car which)])
(error 'set-language-level! "couldn't find language: ~e, double match ~e" (cond
in-language-spec name)) [(null? (cdr language-spec))
(let ([next-item (car which)]) (when (is-a? next-item hierarchical-list-compound-item<%>)
(cond (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e"
[(null? (cdr language-spec)) name in-language-spec))
(when (is-a? next-item hierarchical-list-compound-item<%>) (set! found-language? #t)
(error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" (click-on-snip (send next-item get-clickable-snip))]
name in-language-spec)) [else
(click-on-snip (send next-item get-clickable-snip))] (unless (is-a? next-item hierarchical-list-compound-item<%>)
[else (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e"
(unless (is-a? next-item hierarchical-list-compound-item<%>) name in-language-spec))
(error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" (unless (send next-item is-open?)
name in-language-spec)) (click-on-snip (send next-item get-arrow-snip)))
(unless (send next-item is-open?) (loop next-item (cdr language-spec))]))))))
(click-on-snip (send next-item get-arrow-snip)))
(loop next-item (cdr language-spec))]))))
(with-handlers ([exn:fail? (lambda (x) (void))]) (unless found-language?
(fw:test:button-push "Show Details")) (error 'set-language-level! "couldn't find language: ~e" in-language-spec))
(fw:test:button-push "Revert to Language Defaults") (with-handlers ([exn:fail? (lambda (x) (void))])
(fw:test:button-push "Show Details"))
(fw:test:button-push "Revert to Language Defaults")
(when close-dialog?
(fw:test:button-push "OK")
(let ([new-frame (wait-for-new-frame language-dialog)])
(unless (eq? new-frame drs-frame)
(error 'set-language-level!
"didn't get drracket frame back, got: ~s (drs-frame ~s)\n"
new-frame
drs-frame)))))))
(when close-dialog?
(fw:test:button-push "OK")
(let ([new-frame (wait-for-new-frame language-dialog)])
(unless (eq? new-frame drs-frame)
(error 'set-language-level!
"didn't get drracket frame back, got: ~s (drs-frame ~s)\n"
new-frame
drs-frame))))))))
(define (set-module-language! [close-dialog? #t]) (define (set-module-language! [close-dialog? #t])
(not-on-eventspace-handler-thread 'set-module-language!) (not-on-eventspace-handler-thread 'set-module-language!)
(let ([drs-frame (fw:test:get-active-top-level-window)]) (let ([drs-frame (fw:test:get-active-top-level-window)])