renamed the variable bound to the collection-paths list-box object
svn: r10696
This commit is contained in:
parent
f65e0ffeb1
commit
2f22ed7c41
|
@ -310,7 +310,7 @@
|
||||||
|
|
||||||
;; data associated with each item in listbox : boolean
|
;; data associated with each item in listbox : boolean
|
||||||
;; indicates if the entry is the default paths.
|
;; indicates if the entry is the default paths.
|
||||||
(define lb (new list-box%
|
(define collection-paths-lb (new list-box%
|
||||||
[parent cp-panel]
|
[parent cp-panel]
|
||||||
[choices '("a" "b" "c")]
|
[choices '("a" "b" "c")]
|
||||||
[label #f]
|
[label #f]
|
||||||
|
@ -336,8 +336,8 @@
|
||||||
(λ (x y) (move-callback +1))))
|
(λ (x y) (move-callback +1))))
|
||||||
|
|
||||||
(define (update-buttons)
|
(define (update-buttons)
|
||||||
(let ([lb-selection (send lb get-selection)]
|
(let ([lb-selection (send collection-paths-lb get-selection)]
|
||||||
[lb-tot (send lb get-number)])
|
[lb-tot (send collection-paths-lb get-number)])
|
||||||
(send remove-button enable lb-selection)
|
(send remove-button enable lb-selection)
|
||||||
(send raise-button enable (and lb-selection (not (= lb-selection 0))))
|
(send raise-button enable (and lb-selection (not (= lb-selection 0))))
|
||||||
(send lower-button enable
|
(send lower-button enable
|
||||||
|
@ -347,7 +347,7 @@
|
||||||
(let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path)
|
(let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path)
|
||||||
(send parent get-top-level-window))])
|
(send parent get-top-level-window))])
|
||||||
(when dir
|
(when dir
|
||||||
(send lb append (path->string dir) #f)
|
(send collection-paths-lb append (path->string dir) #f)
|
||||||
(update-buttons))))
|
(update-buttons))))
|
||||||
|
|
||||||
(define (add-default-callback)
|
(define (add-default-callback)
|
||||||
|
@ -356,56 +356,56 @@
|
||||||
(string-constant ml-cp-default-already-present)
|
(string-constant ml-cp-default-already-present)
|
||||||
(send parent get-top-level-window))]
|
(send parent get-top-level-window))]
|
||||||
[else
|
[else
|
||||||
(send lb append (string-constant ml-cp-default-collection-path) #t)
|
(send collection-paths-lb append (string-constant ml-cp-default-collection-path) #t)
|
||||||
(update-buttons)]))
|
(update-buttons)]))
|
||||||
|
|
||||||
;; has-default? : -> boolean
|
;; has-default? : -> boolean
|
||||||
;; returns #t if the `default' entry has already been added
|
;; returns #t if the `default' entry has already been added
|
||||||
(define (has-default?)
|
(define (has-default?)
|
||||||
(let loop ([n (send lb get-number)])
|
(let loop ([n (send collection-paths-lb get-number)])
|
||||||
(cond [(= n 0) #f]
|
(cond [(= n 0) #f]
|
||||||
[(send lb get-data (- n 1)) #t]
|
[(send collection-paths-lb get-data (- n 1)) #t]
|
||||||
[else (loop (- n 1))])))
|
[else (loop (- n 1))])))
|
||||||
|
|
||||||
(define (remove-callback)
|
(define (remove-callback)
|
||||||
(let ([to-delete (send lb get-selection)])
|
(let ([to-delete (send collection-paths-lb get-selection)])
|
||||||
(send lb delete to-delete)
|
(send collection-paths-lb delete to-delete)
|
||||||
(unless (zero? (send lb get-number))
|
(unless (zero? (send collection-paths-lb get-number))
|
||||||
(send lb set-selection (min to-delete (- (send lb get-number) 1))))
|
(send collection-paths-lb set-selection (min to-delete (- (send collection-paths-lb get-number) 1))))
|
||||||
(update-buttons)))
|
(update-buttons)))
|
||||||
|
|
||||||
(define (move-callback d)
|
(define (move-callback d)
|
||||||
(let* ([sel (send lb get-selection)]
|
(let* ([sel (send collection-paths-lb get-selection)]
|
||||||
[vec (get-lb-vector)]
|
[vec (get-lb-vector)]
|
||||||
[new (+ sel d)]
|
[new (+ sel d)]
|
||||||
[other (vector-ref vec new)])
|
[other (vector-ref vec new)])
|
||||||
(vector-set! vec new (vector-ref vec sel))
|
(vector-set! vec new (vector-ref vec sel))
|
||||||
(vector-set! vec sel other)
|
(vector-set! vec sel other)
|
||||||
(set-lb-vector vec)
|
(set-lb-vector vec)
|
||||||
(send lb set-selection new)
|
(send collection-paths-lb set-selection new)
|
||||||
(update-buttons)))
|
(update-buttons)))
|
||||||
|
|
||||||
(define (get-lb-vector)
|
(define (get-lb-vector)
|
||||||
(list->vector (for/list ([n (in-range (send lb get-number))])
|
(list->vector (for/list ([n (in-range (send collection-paths-lb get-number))])
|
||||||
(cons (send lb get-string n) (send lb get-data n)))))
|
(cons (send collection-paths-lb get-string n) (send collection-paths-lb get-data n)))))
|
||||||
|
|
||||||
(define (set-lb-vector vec)
|
(define (set-lb-vector vec)
|
||||||
(send lb clear)
|
(send collection-paths-lb clear)
|
||||||
(for ([x (in-vector vec)] [n (in-naturals)])
|
(for ([x (in-vector vec)] [n (in-naturals)])
|
||||||
(send lb append (car x))
|
(send collection-paths-lb append (car x))
|
||||||
(send lb set-data n (cdr x))))
|
(send collection-paths-lb set-data n (cdr x))))
|
||||||
|
|
||||||
(define (get-collection-paths)
|
(define (get-collection-paths)
|
||||||
(for/list ([n (in-range (send lb get-number))])
|
(for/list ([n (in-range (send collection-paths-lb get-number))])
|
||||||
(let ([data (send lb get-data n)])
|
(let ([data (send collection-paths-lb get-data n)])
|
||||||
(if data 'default (send lb get-string n)))))
|
(if data 'default (send collection-paths-lb get-string n)))))
|
||||||
|
|
||||||
(define (install-collection-paths paths)
|
(define (install-collection-paths paths)
|
||||||
(send lb clear)
|
(send collection-paths-lb clear)
|
||||||
(for ([cp paths])
|
(for ([cp paths])
|
||||||
(if (symbol? cp)
|
(if (symbol? cp)
|
||||||
(send lb append (string-constant ml-cp-default-collection-path) #t)
|
(send collection-paths-lb append (string-constant ml-cp-default-collection-path) #t)
|
||||||
(send lb append cp #f))))
|
(send collection-paths-lb append cp #f))))
|
||||||
|
|
||||||
(define (get-command-line-args)
|
(define (get-command-line-args)
|
||||||
(let* ([str (send args-text-box get-value)]
|
(let* ([str (send args-text-box get-value)]
|
||||||
|
@ -427,7 +427,7 @@
|
||||||
(define (install-auto-text str)
|
(define (install-auto-text str)
|
||||||
(send auto-text-text-box set-value (regexp-replace #rx"\n$" str "")))
|
(send auto-text-text-box set-value (regexp-replace #rx"\n$" str "")))
|
||||||
|
|
||||||
(send lb set '())
|
(send collection-paths-lb set '())
|
||||||
(update-buttons)
|
(update-buttons)
|
||||||
|
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
Loading…
Reference in New Issue
Block a user