diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 3cb27384e0..20dacbd806 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -139,7 +139,7 @@ (define/override (on-subwindow-char receiver evt) (case (send evt get-key-code) [(escape) (cancel-callback)] - [(#\return numpad-enter) (ok-callback)] + [(#\return numpad-enter) (enter-callback)] [else (super on-subwindow-char receiver evt)])) (super-instantiate ()))) @@ -161,35 +161,7 @@ (define button-panel (instantiate horizontal-pane% () (parent dialog) (stretchable-height #f))) - - (define-values (get-selected-language get-selected-language-settings) - (fill-language-dialog language-dialog-meat-panel - button-panel - language-settings-to-show - #f - manuals?)) - - ;; cancelled? : boolean - ;; flag that indicates if the dialog was cancelled. - (define cancelled? #t) - - ;; ok-callback : -> void - (define (ok-callback) - (cond - [(get-selected-language) - (set! cancelled? #f) - (send dialog show #f)] - [else - (message-box (string-constant drscheme) - (string-constant please-select-a-language))])) - - ;; cancel-callback : -> void - (define (cancel-callback) - (send dialog show #f)) - (define show-details-label (string-constant show-details-button-label)) - (define hide-details-label (string-constant hide-details-button-label)) - (define button-gap (make-object horizontal-pane% button-panel)) (define-values (ok-button cancel-button) (gui-utils:ok/cancel-buttons @@ -197,7 +169,40 @@ (λ (x y) (ok-callback)) (λ (x y) (cancel-callback)))) (define grow-box-spacer (make-object grow-box-spacer-pane% button-panel)) - + + (define-values (get-selected-language get-selected-language-settings) + (fill-language-dialog language-dialog-meat-panel + button-panel + language-settings-to-show + #f + manuals? + ok-button)) + + ;; cancelled? : boolean + ;; flag that indicates if the dialog was cancelled. + (define cancelled? #t) + + ;; ok-callback : -> void + (define (ok-callback) + (cond [(get-selected-language) + (set! cancelled? #f) + (send dialog show #f)] + [else + (message-box (string-constant drscheme) + (string-constant please-select-a-language))])) + ;; enter-callback : -> void similar to the above, but return #f if no + ;; language is selected, so the event will be processed by the list + ;; (which will toggle subtrees) + (define (enter-callback) + (cond [(get-selected-language) + (set! cancelled? #f) + (send dialog show #f)] + [else #f])) + + ;; cancel-callback : -> void + (define (cancel-callback) + (send dialog show #f)) + (when show-welcome? (add-welcome dialog welcome-before-panel welcome-after-panel)) @@ -214,13 +219,13 @@ (get-selected-language-settings))))) ;; fill-language-dialog : (vertical-panel panel language-setting -> language-setting) - ;; (union dialog #f) + ;; (union dialog #f) [...more stuff...] ;; -> (-> (union #f language<%>)) (-> settings[corresponding to fst thnk result]) ;; allows the user to configure their language. The input language-setting is used ;; as the defaults in the dialog and the output language setting is the user's choice ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. (define fill-language-dialog - (opt-lambda (parent show-details-parent language-settings-to-show [re-center #f] [manuals? #f]) + (opt-lambda (parent show-details-parent language-settings-to-show [re-center #f] [manuals? #f] [ok-button #f]) (define-values (language-to-show settings-to-show) (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) @@ -245,89 +250,84 @@ (inherit get-selected) (define/override (on-char evt) (let ([code (send evt get-key-code)]) - (cond - [(eq? code 'up) (select-next sub1 (λ (v) (- (vector-length v) 1)))] - [(eq? code 'down) (select-next add1 (λ (v) 0))] + (case code + [(up) (select-next sub1)] + [(down) (select-next add1)] + ;; right key is fine, but nicer to close after a left + [(left) (super on-char evt) + (cond [(get-selected) => (λ (i) (send i close))])] [else (super on-char evt)]))) - + (inherit get-items) - - ;; select-next : (int -> int) (vector -> int) - ;; finds the next leaf after the selected child, - ;; using `inc' and `start' to control the direction of the traversal. - (define/private (select-next inc start) - (define fst-selected (get-selected)) - (let loop ([item fst-selected]) - (when item - (let* ([parent (send item get-parent)] - [siblings (if parent - (send parent get-items) - (get-items))] - [siblings-len (length siblings)]) - (let sibling-loop ([index (inc (find-index item siblings))]) - (if (< -1 index siblings-len) - (let ([child (find-first-leaf (list-ref siblings index) - inc start)]) - (if child - (begin (send fst-selected select #f) - (send child select #t) - (open-parents child) - (make-visible child)) - (sibling-loop (inc index)))) - (loop parent))))))) - - ;; find-first-leaf : item (int -> int) (vec -> int) - ;; finds the first child, using `inc' and `start' to control - ;; the traversal over the children. - (define/private (find-first-leaf item inc start) - (let loop ([item item]) - (cond - [(is-a? item hierarchical-list-compound-item<%>) - (let ([children (list->vector (send item get-items))]) - (let child-loop ([i (start children)]) - (cond - [(and (<= 0 i) (< i (vector-length children))) - (or (loop (vector-ref children i)) - (child-loop (inc i)))] - [else #f])))] - [(send item get-allow-selection?) - item] - [else #f]))) - ;; find-index : tst (listof tst) -> int - ;; returns the index of `item' in `lst' - (define/private (find-index item lst) - (let loop ([i 0] [l lst]) - (cond [(null? l) - (error 'find-index "didn't find ~e in ~e" item lst)] - [(eq? (car l) item) i] - [else (loop (add1 i) (cdr l))]))) + ;; select-next : (num -> num) -> void + ;; finds the next/prev leaf after the selected child on the open + ;; fringe using `inc' for a direction. + (define/private (select-next inc) + (define current (get-selected)) + (define (choose item) + (when current (send current select #f)) + (send item select #t) + ;; make it visible + (let loop ([item item]) + (let ([parent (send item get-parent)]) + (if parent + (loop parent) + (send item scroll-to)))) + (send item scroll-to)) + (define (selectable? item) + (and (send item get-allow-selection?) + ;; opened all the way to the top + (let loop ([p (send item get-parent)]) + (or (not p) + (and (send p is-open?) + (loop (send p get-parent))))))) + (let* ([fringe (get-fringe)] + [fringe-len (vector-length fringe)] + [n (if current + (let loop ([i (sub1 (vector-length fringe))]) + (cond [(< i 0) (error 'select-next "item not found in fringe")] + [(eq? current (vector-ref fringe i)) + (min (sub1 fringe-len) (max 0 (inc i)))] + [else (loop (sub1 i))])) + (modulo (inc fringe-len) (add1 fringe-len)))]) + ;; need to choose item n, but go on looking for one that is + ;; selectable and open + (let loop ([n n]) + (when (< -1 n fringe-len) + (let ([item (vector-ref fringe n)]) + (if (selectable? item) + (choose item) + (loop (inc n)))))))) - ;; open-parents : item -> void - ;; selects the item and opens all of its parents. - (define/private (open-parents item) - (let loop ([item (send item get-parent)]) - (when item - (send item open) - (loop (send item get-parent))))) - - (define/private (make-visible item) - (let loop ([item item]) - (let ([parent (send item get-parent)]) - (if parent - (loop parent) - (send item scroll-to)))) - (send item scroll-to)) + (define cached-fringe #f) + (define/public (clear-fringe-cache) (set! cached-fringe #f)) + (define (get-fringe) + (unless cached-fringe + (let ([fringe + (let loop ([items (get-items)]) + (apply append + (map (λ (item) + (if (is-a? item hierarchical-list-compound-item<%>) + (cons item + (loop (send item get-items))) + (list item))) + items)))]) + (set! cached-fringe (list->vector fringe)))) + cached-fringe) (define/override (on-select i) - (cond - [(and i (is-a? i hieritem-language<%>)) - (send i selected)] - [else - (nothing-selected)])) + (if (and i (is-a? i hieritem-language<%>)) + (something-selected) + (nothing-selected))) + ;; this is not used, since all lists are selectable (define/override (on-click i) (when (and i (is-a? i hierarchical-list-compound-item<%>)) (send i toggle-open/closed))) + ;; use this instead + (define/override (on-double-select i) + (when (and i (is-a? i hierarchical-list-compound-item<%>)) + (send i toggle-open/closed))) (super-instantiate (parent)))) (define outermost-panel (make-object horizontal-pane% parent)) @@ -336,14 +336,14 @@ (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) (define manual-ordering-panel (new vertical-panel% (parent details/manual-parent-panel))) - + (define manual-ordering-text (new panel-background-text%)) (define manual-ordering-canvas (new panel-background-editor-canvas% (parent manual-ordering-panel) (editor manual-ordering-text) (style '(no-hscroll)) (min-width 300))) - + (define one-line-summary-message (instantiate message% () (parent parent) (label "") @@ -394,7 +394,14 @@ (send details-panel active-child no-details-panel) (send one-line-summary-message set-label "") (set! get/set-selected-language-settings #f) - (set! selected-language #f)) + (set! selected-language #f) + (when ok-button (send ok-button enable #f)) + (send details-button enable #f)) + + ;; something-selected : -> void + (define (something-selected) + (when ok-button (send ok-button enable #t)) + (send details-button enable #t)) ;; update-manual-ordering-text : -> void ;; updates the manual ordering text with the order the manuals are searched for this language @@ -478,6 +485,7 @@ (error 'drscheme:language "languages position and numbers must be lists of strings and numbers, respectively, must have the same length, and must each contain at least two elements, got: ~e ~e" positions numbers)) + (send languages-hier-list clear-fringe-cache) #| @@ -599,7 +607,7 @@ (send new-list set-number number) (when second-number (send new-list set-second-number second-number)) - (send new-list set-allow-selection #f) + (send new-list set-allow-selection #t) (send new-list open) (send (send new-list get-editor) insert position) (hash-table-put! ht (string->symbol position) x)