From 5768009e3b716ce430244244cf85b7635ccbbbc4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 18:38:18 -0500 Subject: [PATCH] Revise the language dialog to emphasize the teaching languages and the 'in the source' language at the expense of all other dialog-based languages --- .../private/language-configuration.rkt | 572 +++++++++++------- collects/drracket/private/main.rkt | 1 + collects/scribblings/tools/tools.scrbl | 9 +- .../private/english-string-constants.rkt | 5 +- .../drracket/private/drracket-test-util.rkt | 106 ++-- 5 files changed, 412 insertions(+), 281 deletions(-) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index f577a46ff9..1ef2dceb7f 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -17,7 +17,7 @@ (define original-output (current-output-port)) (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)] [menukey-string (apply string-append @@ -40,8 +40,10 @@ shortcut-prefix)) (values (string-append (string-constant use-language-in-source) (format " (~aU)" menukey-string)) - (string-append (string-constant choose-a-language) - (format " (~aC)" menukey-string)) + (string-append (string-constant teaching-languages) + (format " (~aT)" menukey-string)) + (string-append (string-constant other-languages) + (format " (~aO)" menukey-string)) mouse-event-uses-shortcut-prefix?))) (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)) (send dialog stretchable-width #f) - (send dialog stretchable-height #t) + (send dialog stretchable-height #f) (unless parent (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. (define fill-language-dialog (λ (parent show-details-parent language-settings-to-show - [re-center #f] - [ok-handler void]) ; en/disable button, execute it + [re-center #f] + [ok-handler void]) ; en/disable button, execute it (define-values (language-to-show settings-to-show) (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) @@ -376,9 +378,13 @@ (cond [(and i (is-a? i hieritem-language<%>)) (define pos (send (send i get-language) get-language-position)) - (preferences:set 'drracket:language-dialog:hierlist-default pos) - (set! most-recent-languages-hier-list-selection pos) - (something-selected i)] + (if (eq? this teaching-languages-hier-list) + (preferences:set 'drracket:language-dialog:teaching-hierlist-default pos) + (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 (non-language-selected)])) ;; this is used only because we set `on-click-always' @@ -388,7 +394,7 @@ ;; double-click selects a language (define/override (on-double-select i) (when (and i (is-a? i hieritem-language<%>)) - (something-selected i) + (something-selected this i) (ok-handler 'execute))) (super-new [parent parent]) ;; do this so we can expand/collapse languages on a single click @@ -396,9 +402,12 @@ (on-click-always #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% [parent outermost-panel] + [stretchable-height #f] [alignment '(left top)])) (define use-language-in-source-rb @@ -411,7 +420,8 @@ (use-language-in-source-rb-callback))])) (define (use-language-in-source-rb-callback) (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% [parent languages-choice-panel] [stretchable-height #f])) @@ -421,6 +431,39 @@ [min-width 32])) (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-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 (new radio-box% [label #f] @@ -430,19 +473,35 @@ (λ (this-rb evt) (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 - (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 languages-hier-list focus)) - (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) + (send use-teaching-language-rb set-selection #f) + (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% [parent languages-hier-list-panel] [stretchable-width #f] [min-width 16])) - (define languages-hier-list (new selectable-hierlist% - [parent languages-hier-list-panel] - [style '(no-border no-hscroll auto-vscroll transparent)])) + (define other-languages-hier-list (new selectable-hierlist% + [parent languages-hier-list-panel] + [style '(no-border no-hscroll auto-vscroll transparent)])) (define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) @@ -493,9 +552,11 @@ (define (module-language-selected) ;; need to deselect things in the languages-hier-list at this point. - (send languages-hier-list select #f) - (send use-chosen-language-rb set-selection #f) + (send other-languages-hier-list select #f) + (send teaching-languages-hier-list select #f) (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) (send details-button enable #t) (update-gui-based-on-selected-language module-language*language @@ -504,12 +565,14 @@ ;; no-language-selected : -> void ;; 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 ;; (ie the user has just started drracket for the first time) (define (no-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*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 ;; for when some non-language is selected in the hierlist (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 details-panel active-child no-details-panel) (send one-line-summary-message set-label "") @@ -530,10 +591,18 @@ (send details-button enable #f)) ;; something-selected : item -> void - (define (something-selected item) - (send use-chosen-language-rb set-selection 0) + (define (something-selected hierlist item) (send use-language-in-source-rb set-selection #f) - (ok-handler 'enable) + (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) (send details-button enable #t) (send item selected)) @@ -546,34 +615,38 @@ ;; when `language' matches language-to-show, update the settings ;; panel to match language-to-show, otherwise set to defaults. (define (add-language-to-dialog language) - (let ([positions (send language get-language-position)] - [numbers (send language get-language-numbers)]) + (define positions (send language get-language-position)) + (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 ... + (unless (equal? positions initial-language-position) + (unless (and (list? positions) + (list? numbers) + (pair? positions) + (pair? numbers) + (andmap number? numbers) + (andmap string? positions) + (= (length positions) (length numbers)) + ((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)) - ;; don't show the initial language ... - (unless (equal? positions initial-language-position) - (unless (and (list? positions) - (list? numbers) - (pair? positions) - (pair? numbers) - (andmap number? numbers) - (andmap string? positions) - (= (length positions) (length numbers)) - ((length numbers) . >= . 1)) + (when (null? (cdr positions)) + (unless (equal? positions (list (string-constant module-language-name))) (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 - "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) - - #| + "Only the module language may be at the top level. Other languages must have at least two levels"))) + + (send other-languages-hier-list clear-fringe-cache) + (send teaching-languages-hier-list clear-fringe-cache) + + #| 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 @@ -581,67 +654,72 @@ what the sorting number is for its level above (in the second-number mixin) |# - - (let add-sub-language ([ht languages-table] - [hier-list languages-hier-list] - [positions positions] - [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)]) - - (set! construct-details - (let ([old construct-details]) - (lambda () - (old) - (let-values ([(language-details-panel-real get/set-settings) - (make-details-panel language)]) - (set! language-details-panel language-details-panel-real) - (set! real-get/set-settings get/set-settings)) - - (let-values ([(vis-lang vis-settings) - (cond - [(and (not selected-language) - (eq? language-to-show language)) - (values language-to-show settings-to-show)] - [(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)] + (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)]) + + (set! construct-details + (let ([old construct-details]) + (lambda () + (old) + (let-values ([(language-details-panel-real get/set-settings) + (make-details-panel language)]) + (set! language-details-panel language-details-panel-real) + (set! real-get/set-settings get/set-settings)) + + (let-values ([(vis-lang vis-settings) + (cond + [(and (not selected-language) + (eq? language-to-show language)) + (values language-to-show settings-to-show)] + [(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 (let* ([mixin (compose number-mixin @@ -671,61 +749,62 @@ (send language get-style-delta) 0 (send text last-position))])))]))] - [else (let* ([position (car positions)] - [number (car numbers)] - [sub-ht/sub-hier-list - (hash-ref - ht - (string->symbol position) - (λ () - (if first? - (let* ([item (send hier-list new-item number-mixin)] - [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)] - [pos (send editor last-position)]) - (send editor insert "\n") - (send editor insert position) - (send editor change-style small-size-delta pos (+ pos 1)) - (send editor change-style section-style-delta - (+ pos 1) (send editor last-position))) - x) - (let* ([new-list (send hier-list new-list - (if second-number - (compose second-number-mixin number-mixin) - number-mixin))] - [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-set! ht (string->symbol position) x) - x))))]) - (cond - [first? - (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) - (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" - (send language get-language-name) - position - (send (caddr sub-ht/sub-hier-list) get-number) - number))] - [else - (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) - (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" - (send language get-language-name) - position - (send (cadr sub-ht/sub-hier-list) get-number) - number))]) - (add-sub-language (car sub-ht/sub-hier-list) - (cadr sub-ht/sub-hier-list) - (cdr positions) - (cdr numbers) - #f - (if first? number #f)))]))))) + [else + (let* ([position (car positions)] + [number (car numbers)] + [sub-ht/sub-hier-list + (hash-ref + ht + (string->symbol position) + (λ () + (if first? + (let* ([item (send hier-list new-item number-mixin)] + [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)] + [pos (send editor last-position)]) + (send editor insert "\n") + (send editor insert position) + (send editor change-style small-size-delta pos (+ pos 1)) + (send editor change-style section-style-delta + (+ pos 1) (send editor last-position))) + x) + (let* ([new-list (send hier-list new-list + (if second-number + (compose second-number-mixin number-mixin) + number-mixin))] + [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-set! ht (string->symbol position) x) + x))))]) + (cond + [first? + (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (caddr sub-ht/sub-hier-list) get-number) + number))] + [else + (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (cadr sub-ht/sub-hier-list) get-number) + number))]) + (add-sub-language (car sub-ht/sub-hier-list) + (cadr sub-ht/sub-hier-list) + (cdr positions) + (cdr numbers) + #f + (if first? number #f)))])))) (define number<%> (interface () @@ -779,35 +858,59 @@ (send item close) (close-children item)] [else (void)])) - (close-children languages-hier-list)) + (close-children other-languages-hier-list) + (close-children teaching-languages-hier-list)) ;; open-current-language : -> void ;; opens the tabs that lead to the current language ;; and selects the 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 [(not (and language-to-show settings-to-show)) (no-language-selected)] [(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 (module-language-selected)] [else - (send languages-hier-list focus) ;; only focus when the module language isn't selected - (send use-chosen-language-rb set-selection 0) - (send use-language-in-source-rb set-selection #f) - (select-a-language-in-hierlist (send language-to-show get-language-position))])) + (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 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 [(null? (cdr language-position)) ;; nothing to open here - (send (car (send languages-hier-list get-items)) select #t) - (void)] + (send (car (send hier-list get-items)) select #t)] [else - (let loop ([hi languages-hier-list] + (let loop ([hi hier-list] ;; skip the first position, since it is flattened into the dialog [first-pos (cadr language-position)] @@ -819,8 +922,6 @@ (send hi get-items))]) (cond [(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)] [else (let ([child (car matching-children)]) @@ -828,8 +929,9 @@ [(null? position) (send child select #t)] [else - (send child open) - (loop child (car position) (cdr position))]))])))])) + (when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad + (send child open) + (loop child (car position) (cdr position)))]))])))])) ;; docs-callback : -> void (define (docs-callback) @@ -901,46 +1003,47 @@ (send revert-to-defaults-outer-panel stretchable-width #f) (send revert-to-defaults-outer-panel stretchable-height #f) - (send outermost-panel set-alignment 'center 'center) (for-each add-language-to-dialog languages) - (send languages-hier-list sort - (λ (x y) - (cond - [(and (x . is-a? . second-number<%>) - (y . is-a? . second-number<%>)) - (cond - [(= (send x get-second-number) - (send y get-second-number)) - (< (send x get-number) (send y get-number))] - [else - (< (send x get-second-number) - (send y get-second-number))])] - [(and (x . is-a? . number<%>) - (y . is-a? . second-number<%>)) - (cond - [(= (send x get-number) - (send y get-second-number)) - #t] - [else - (< (send x get-number) - (send y get-second-number))])] - [(and (x . is-a? . second-number<%>) - (y . is-a? . number<%>)) - (cond - [(= (send x get-second-number) - (send y get-number)) - #f] - [else (< (send x get-second-number) - (send y get-number))])] - [(and (x . is-a? . number<%>) - (y . is-a? . number<%>)) - (< (send x get-number) (send y get-number))] - [else #f]))) + (define (hier-list-sort-predicate x y) + (cond + [(and (x . is-a? . second-number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-second-number) + (send y get-second-number)) + (< (send x get-number) (send y get-number))] + [else + (< (send x get-second-number) + (send y get-second-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-number) + (send y get-second-number)) + #t] + [else + (< (send x get-number) + (send y get-second-number))])] + [(and (x . is-a? . second-number<%>) + (y . is-a? . number<%>)) + (cond + [(= (send x get-second-number) + (send y get-number)) + #f] + [else (< (send x get-second-number) + (send y get-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . number<%>)) + (< (send x get-number) (send y get-number))] + [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) ;; 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)) (send t delete 0 1))) @@ -949,15 +1052,21 @@ (λ (l) (list details-panel))) - (send languages-hier-list stretchable-width #t) - (send languages-hier-list stretchable-height #t) - (send languages-hier-list accept-tab-focus #t) - (send languages-hier-list allow-tab-exit #t) + (define (config-hier-list hier-list) + (send hier-list stretchable-width #t) + (send hier-list stretchable-height #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) (close-all-languages) (open-current-language) - (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor))) - (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor))) + (define (set-min-sizes hier-list) + (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? (do-construct-details)) (update-show/hide-details) @@ -979,7 +1088,14 @@ (use-language-in-source-rb-callback) #t) #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) (begin (send use-chosen-language-rb set-selection 0) @@ -1178,7 +1294,7 @@ #f #f #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)))))) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 0fd6472ece..1ace972f97 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -72,6 +72,7 @@ (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))))) +(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-base 'racket (λ (x) (memq x '(racket gracket)))) diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 3b3fc3011d..ec535c8b24 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -10,7 +10,8 @@ (for-label racket/base racket/gui) (for-label framework/framework) (for-label drracket/syncheck-drracket-button - drracket/check-syntax) + drracket/check-syntax + string-constants/string-constant) scribble/eval scribble/extract) @@ -318,6 +319,12 @@ This must be bound to a corresponds to the position of the language in language dialog. Each language position is a list of strings whose 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]{ This is optional. If diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 95714b2ff6..1488589ad1 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1153,9 +1153,10 @@ please adhere to these guidelines: (experimental-languages "Experimental Languages") (initial-language-category "Initial language") (no-language-chosen "No language chosen") - + (other-languages "Other Languages") + (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 ;; for the upper portion of the language dialog diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index b5aa08cc36..0c6482d2e4 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -353,21 +353,25 @@ (not-on-eventspace-handler-thread 'set-language-level!) (let ([drs-frame (fw:test:get-active-top-level-window)]) (fw:test:menu-select "Language" "Choose Language...") - (let* ([language-dialog (wait-for-new-frame drs-frame)] - [language-choice (find-labelled-window #f hierarchical-list% (fw:test:get-active-top-level-window))] - [b1 (box 0)] - [b2 (box 0)] - [click-on-snip - (lambda (snip) - (let* ([editor (send (send snip get-admin) get-editor)] - [between-threshold (send editor get-between-threshold)]) - (send editor get-snip-location snip b1 b2) - (let-values ([(gx gy) (send editor editor-location-to-dc-location - (unbox b1) - (unbox b2))]) - (let ([x (inexact->exact (floor (+ gx between-threshold 1)))] - [y (inexact->exact (floor (+ gy between-threshold 1)))]) - (fw:test:mouse-click 'left x y)))))]) + (define language-dialog (wait-for-new-frame drs-frame)) + (fw:test:set-radio-box-item! #rx"Other Languages") + (define language-choices (find-labelled-windows #f hierarchical-list% (fw:test:get-active-top-level-window))) + (define b1 (box 0)) + (define b2 (box 0)) + (define (click-on-snip snip) + (let* ([editor (send (send snip get-admin) get-editor)] + [between-threshold (send editor get-between-threshold)]) + (send editor get-snip-location snip b1 b2) + (let-values ([(gx gy) (send editor editor-location-to-dc-location + (unbox b1) + (unbox b2))]) + (let ([x (inexact->exact (floor (+ gx between-threshold 1)))] + [y (inexact->exact (floor (+ gy between-threshold 1)))]) + (fw:test:mouse-click 'left x y))))) + + (define found-language? #f) + + (for ([language-choice (in-list language-choices)]) (send language-choice focus) (let loop ([list-item language-choice] [language-spec in-language-spec]) @@ -382,41 +386,43 @@ (and matches child))) (send list-item get-items))]) - (when (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)) - (error 'set-language-level! "couldn't find language: ~e, double match ~e" - in-language-spec name)) - (let ([next-item (car which)]) - (cond - [(null? (cdr language-spec)) - (when (is-a? next-item hierarchical-list-compound-item<%>) - (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" - name in-language-spec)) - (click-on-snip (send next-item get-clickable-snip))] - [else - (unless (is-a? next-item hierarchical-list-compound-item<%>) - (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" - name in-language-spec)) - (unless (send next-item is-open?) - (click-on-snip (send next-item get-arrow-snip))) - (loop next-item (cdr language-spec))])))) - - (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)))))))) + (unless (null? which) + (unless (= 1 (length which)) + (error 'set-language-level! "couldn't find language: ~e, double match ~e" + in-language-spec name)) + (let ([next-item (car which)]) + (cond + [(null? (cdr language-spec)) + (when (is-a? next-item hierarchical-list-compound-item<%>) + (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" + name in-language-spec)) + (set! found-language? #t) + (click-on-snip (send next-item get-clickable-snip))] + [else + (unless (is-a? next-item hierarchical-list-compound-item<%>) + (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" + name in-language-spec)) + (unless (send next-item is-open?) + (click-on-snip (send next-item get-arrow-snip))) + (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))]) + (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))))))) + (define (set-module-language! [close-dialog? #t]) (not-on-eventspace-handler-thread 'set-module-language!) (let ([drs-frame (fw:test:get-active-top-level-window)])