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

232
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))
@ -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,17 +473,33 @@
(λ (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))
@ -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,8 +615,11 @@
;; 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)
@ -571,7 +643,8 @@
(error 'drracket:language (error 'drracket:language
"Only the module language may be at the top level. Other languages must have at least two levels"))) "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) (send other-languages-hier-list clear-fringe-cache)
(send teaching-languages-hier-list clear-fringe-cache)
#| #|
@ -581,11 +654,16 @@
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] (let add-sub-language ([ht languages-table]
[hier-list languages-hier-list] [hier-list (if teaching-language?
[positions positions] teaching-languages-hier-list
[numbers numbers] other-languages-hier-list)]
[positions (if teaching-language?
(cdr positions)
positions)]
[numbers (if teaching-language?
(cdr numbers)
numbers)]
[first? #t] [first? #t]
[second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number
(cond (cond
@ -671,7 +749,8 @@
(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
(let* ([position (car positions)]
[number (car numbers)] [number (car numbers)]
[sub-ht/sub-hier-list [sub-ht/sub-hier-list
(hash-ref (hash-ref
@ -725,7 +804,7 @@
(cdr positions) (cdr positions)
(cdr numbers) (cdr numbers)
#f #f
(if first? number #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))
(cond
[(and (pair? 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 use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f) (send other-languages-hier-list focus)])
(select-a-language-in-hierlist (send language-to-show get-language-position))])) (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
(when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad
(send child open) (send child open)
(loop child (car position) (cdr position))]))])))])) (loop child (car position) (cdr position)))]))])))]))
;; docs-callback : -> void ;; docs-callback : -> void
(define (docs-callback) (define (docs-callback)
@ -901,11 +1003,9 @@
(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<%>))
@ -936,11 +1036,14 @@
[(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

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

@ -353,12 +353,12 @@
(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)
@ -367,7 +367,11 @@
(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,10 +386,7 @@
(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"
in-language-spec name (map (λ (child) (send (send child get-editor) get-text))
(send list-item get-items))))
(unless (= 1 (length which)) (unless (= 1 (length which))
(error 'set-language-level! "couldn't find language: ~e, double match ~e" (error 'set-language-level! "couldn't find language: ~e, double match ~e"
in-language-spec name)) in-language-spec name))
@ -395,6 +396,7 @@
(when (is-a? next-item hierarchical-list-compound-item<%>) (when (is-a? next-item hierarchical-list-compound-item<%>)
(error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e"
name in-language-spec)) name in-language-spec))
(set! found-language? #t)
(click-on-snip (send next-item get-clickable-snip))] (click-on-snip (send next-item get-clickable-snip))]
[else [else
(unless (is-a? next-item hierarchical-list-compound-item<%>) (unless (is-a? next-item hierarchical-list-compound-item<%>)
@ -402,7 +404,10 @@
name in-language-spec)) name in-language-spec))
(unless (send next-item is-open?) (unless (send next-item is-open?)
(click-on-snip (send next-item get-arrow-snip))) (click-on-snip (send next-item get-arrow-snip)))
(loop next-item (cdr language-spec))])))) (loop next-item (cdr language-spec))]))))))
(unless found-language?
(error 'set-language-level! "couldn't find language: ~e" in-language-spec))
(with-handlers ([exn:fail? (lambda (x) (void))]) (with-handlers ([exn:fail? (lambda (x) (void))])
(fw:test:button-push "Show Details")) (fw:test:button-push "Show Details"))
@ -416,7 +421,8 @@
(error 'set-language-level! (error 'set-language-level!
"didn't get drracket frame back, got: ~s (drs-frame ~s)\n" "didn't get drracket frame back, got: ~s (drs-frame ~s)\n"
new-frame new-frame
drs-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)])