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

removed default language from language dialgo

Browse Source 
svn: r1470
This commit is contained in:
Robby Findler 2005-12-01 21:44:41 +00:00
parent 88bb2b39ee
commit 0588b527c3
1 changed files with 186 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,8 +12,6 @@
(lib "list.ss") (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "file.ss") (lib "file.ss")
(lib "pconvert.ss")
(lib "bitmap-label.ss" "mrlib")
(lib "getinfo.ss" "setup") (lib "getinfo.ss" "setup")
(lib "toplevel.ss" "syntax")) (lib "toplevel.ss" "syntax"))
@ -43,7 +41,7 @@
;; default-language-position : (listof string) ;; default-language-position : (listof string)
;; if a language is registered with this position, it is ;; if a language is registered with this position, it is
;; considered the default language ;; considered the default language
(define default-language-position (define initial-language-position
(list (string-constant initial-language-category) (list (string-constant initial-language-category)
(string-constant no-language-chosen))) (string-constant no-language-chosen)))
@ -85,7 +83,7 @@
(error 'get-default-language-settings "no languages registered!")) (error 'get-default-language-settings "no languages registered!"))
(let ([lang (or (ormap (λ (x) (let ([lang (or (ormap (λ (x)
(and (equal? (send x get-language-position) (and (equal? (send x get-language-position)
default-language-position) initial-language-position)
x)) x))
(get-languages)) (get-languages))
(first (get-languages)))]) (first (get-languages)))])
@ -210,9 +208,16 @@
(define fill-language-dialog (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])
(define language-to-show (language-settings-language language-settings-to-show)) (define-values (language-to-show settings-to-show)
(define settings-to-show (language-settings-settings language-settings-to-show)) (let ([request-lang-to-show (language-settings-language language-settings-to-show)])
(cond
[(equal? initial-language-position (send request-lang-to-show get-language-position))
(values (first (get-languages))
(send (first (get-languages)) default-settings))
(values #f #f)]
[else (values request-lang-to-show
(language-settings-settings language-settings-to-show))])))
;; hier-list items that implement this interface correspond to ;; hier-list items that implement this interface correspond to
;; actual language selections ;; actual language selections
(define hieritem-language<%> (define hieritem-language<%>
@ -452,19 +457,22 @@
(define (add-language-to-dialog language) (define (add-language-to-dialog language)
(let ([positions (send language get-language-position)] (let ([positions (send language get-language-position)]
[numbers (send language get-language-numbers)]) [numbers (send language get-language-numbers)])
(unless (and (list? positions)
(list? numbers)
(pair? positions)
(pair? numbers)
(andmap number? numbers)
(andmap string? positions)
(= (length positions) (length numbers))
((length numbers) . >= . 2))
(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))
#| ;; 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) . >= . 2))
(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))
#|
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
@ -472,137 +480,143 @@
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 languages-hier-list]
[positions positions] [positions positions]
[numbers numbers] [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
[(null? (cdr positions)) [(null? (cdr positions))
(let* ([language-details-panel #f] (let* ([language-details-panel #f]
[real-get/set-settings [real-get/set-settings
(case-lambda (case-lambda
[() [()
(cond (cond
[(equal? (send language-to-show get-language-position) [(and language-to-show
(send language get-language-position)) settings-to-show
settings-to-show] (equal? (send language-to-show get-language-position)
[else (send language get-language-position)))
(send language default-settings)])] settings-to-show]
[(x) (void)])] [else
[get-language-details-panel (send language default-settings)])]
(lambda () language-details-panel)] [(x) (void)])]
[get/set-settings (lambda x (apply real-get/set-settings x))] [get-language-details-panel
[position (car positions)] (lambda () language-details-panel)]
[number (car numbers)] [get/set-settings (lambda x (apply real-get/set-settings x))]
[mixin (compose [position (car positions)]
number-mixin [number (car numbers)]
(language-mixin language get-language-details-panel get/set-settings))] [mixin (compose
[item number-mixin
(send hier-list new-item (language-mixin language get-language-details-panel get/set-settings))]
(if second-number [item
(compose second-number-mixin mixin) (send hier-list new-item
mixin))] (if second-number
[text (send item get-editor)] (compose second-number-mixin mixin)
[delta (send language get-style-delta)]) mixin))]
[text (send item get-editor)]
(set! construct-details [delta (send language get-style-delta)])
(let ([old construct-details])
(lambda () (set! construct-details
(old) (let ([old construct-details])
(let-values ([(language-details-panel-real get/set-settings) (lambda ()
(make-details-panel language)]) (old)
(set! language-details-panel language-details-panel-real) (let-values ([(language-details-panel-real get/set-settings)
(set! real-get/set-settings get/set-settings)) (make-details-panel language)])
(set! language-details-panel language-details-panel-real)
(let-values ([(vis-lang vis-settings) (set! real-get/set-settings get/set-settings))
(if selected-language
(values selected-language (let-values ([(vis-lang vis-settings)
(send selected-language default-settings)) (cond
(values language-to-show settings-to-show))]) [selected-language
(cond (values selected-language
[(equal? (send vis-lang get-language-position) (send selected-language default-settings))]
(send language get-language-position)) [(and language-to-show settings-to-show)
(get/set-settings vis-settings) (values language-to-show settings-to-show)]
(send details-panel active-child language-details-panel)] [else (values #f #f)])])
[else (cond
(get/set-settings (send language default-settings))]))))) [(not vis-lang) (void)]
[(equal? (send vis-lang get-language-position)
(send item set-number number) (send language get-language-position))
(when second-number (get/set-settings vis-settings)
(send item set-second-number second-number)) (send details-panel active-child language-details-panel)]
(send text insert position) [else
(when delta (get/set-settings (send language default-settings))])))))
(cond
[(list? delta) (send item set-number number)
(for-each (λ (x) (when second-number
(send text change-style (send item set-second-number second-number))
(car x) (send text insert position)
(cadr x) (when delta
(caddr x))) (cond
delta)] [(list? delta)
[(is-a? delta style-delta%) (for-each (λ (x)
(send text change-style (send text change-style
(send language get-style-delta) (car x)
0 (cadr x)
(send text last-position))])))] (caddr x)))
[else (let* ([position (car positions)] delta)]
[number (car numbers)] [(is-a? delta style-delta%)
[sub-ht/sub-hier-list (send text change-style
(hash-table-get (send language get-style-delta)
ht 0
(string->symbol position) (send text last-position))])))]
(λ () [else (let* ([position (car positions)]
(if first? [number (car numbers)]
(let* ([item (send hier-list new-item number-mixin)] [sub-ht/sub-hier-list
[x (list (make-hash-table) hier-list item)]) (hash-table-get
(hash-table-put! ht (string->symbol position) x) ht
(send item set-number number) (string->symbol position)
(send item set-allow-selection #f) (λ ()
(let* ([editor (send item get-editor)] (if first?
[pos (send editor last-position)]) (let* ([item (send hier-list new-item number-mixin)]
(send editor insert "\n") [x (list (make-hash-table) hier-list item)])
(send editor insert position) (hash-table-put! ht (string->symbol position) x)
(send editor change-style small-size-delta pos (+ pos 1)) (send item set-number number)
(send editor change-style section-style-delta (send item set-allow-selection #f)
(+ pos 1) (send editor last-position))) (let* ([editor (send item get-editor)]
x) [pos (send editor last-position)])
(let* ([new-list (send hier-list new-list (send editor insert "\n")
(if second-number (send editor insert position)
(compose second-number-mixin number-mixin) (send editor change-style small-size-delta pos (+ pos 1))
number-mixin))] (send editor change-style section-style-delta
[x (list (make-hash-table) new-list #f)]) (+ pos 1) (send editor last-position)))
(send new-list set-number number) x)
(when second-number (let* ([new-list (send hier-list new-list
(send new-list set-second-number second-number)) (if second-number
(send new-list set-allow-selection #f) (compose second-number-mixin number-mixin)
(send new-list open) number-mixin))]
(send (send new-list get-editor) insert position) [x (list (make-hash-table) new-list #f)])
(hash-table-put! ht (string->symbol position) x) (send new-list set-number number)
x))))]) (when second-number
(cond (send new-list set-second-number second-number))
[first? (send new-list set-allow-selection #f)
(unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) (send new-list open)
(error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" (send (send new-list get-editor) insert position)
(send language get-language-name) (hash-table-put! ht (string->symbol position) x)
position x))))])
(send (caddr sub-ht/sub-hier-list) get-number) (cond
number))] [first?
[else (unless (= number (send (caddr sub-ht/sub-hier-list) get-number))
(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"
(error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" (send language get-language-name)
(send language get-language-name) position
position (send (caddr sub-ht/sub-hier-list) get-number)
(send (cadr sub-ht/sub-hier-list) get-number) number))]
number))]) [else
(add-sub-language (car sub-ht/sub-hier-list) (unless (= number (send (cadr sub-ht/sub-hier-list) get-number))
(cadr sub-ht/sub-hier-list) (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
(cdr positions) (send language get-language-name)
(cdr numbers) position
#f (send (cadr sub-ht/sub-hier-list) get-number)
(if first? number #f)))])))) 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<%> (define number<%>
(interface () (interface ()
@ -662,24 +676,25 @@
;; 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)
(let loop ([hi languages-hier-list] (when (and language-to-show settings-to-show)
(let loop ([hi languages-hier-list]
;; skip the first position, since it is flattened into the dialog
[first-pos (cadr (send language-to-show get-language-position))] ;; skip the first position, since it is flattened into the dialog
[position (cddr (send language-to-show get-language-position))]) [first-pos (cadr (send language-to-show get-language-position))]
(let ([child [position (cddr (send language-to-show get-language-position))])
;; know that this `car' is okay by construction of the dialog (let ([child
(car ;; know that this `car' is okay by construction of the dialog
(filter (λ (x) (car
(equal? (send (send x get-editor) get-text) (filter (λ (x)
first-pos)) (equal? (send (send x get-editor) get-text)
(send hi get-items)))]) first-pos))
(cond (send hi get-items)))])
[(null? position) (cond
(send child select #t)] [(null? position)
[else (send child select #t)]
(send child open) [else
(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)
@ -687,7 +702,9 @@
;; details-shown? : boolean ;; details-shown? : boolean
;; indicates if the details are currently visible in the dialog ;; indicates if the details are currently visible in the dialog
(define details-shown? (not (send language-to-show default-settings? settings-to-show))) (define details-shown? (and language-to-show
settings-to-show
(not (send language-to-show default-settings? settings-to-show))))
;; details-callback : -> void ;; details-callback : -> void
;; flips the details-shown? flag and resets the GUI ;; flips the details-shown? flag and resets the GUI