GUI package manager: further refinements

Use better labels, such as "Available from Catalog" instead of "By List"
or "Do What I Mean" instead of "By Source".

Add filter box to the "Currently Installed" panel, andmake status marker
the same as on "Available from Catalog".
This commit is contained in:
Matthew Flatt 2013-08-21 10:55:54 -06:00
parent ef54fc470c
commit c16c04dab0
8 changed files with 195 additions and 99 deletions

View File

@ -6,6 +6,7 @@
pkg/lib pkg/lib
pkg pkg
string-constants string-constants
"filter-panel.rkt"
"common.rkt") "common.rkt")
(provide by-installed-panel%) (provide by-installed-panel%)
@ -18,6 +19,26 @@
(path->string (path->complete-path s dir)) (path->string (path->complete-path s dir))
s)) s))
(define (source->string s)
(format "~a: ~a"
(case (car s)
[(catalog) "Catalog"]
[(url) "URL"]
[(link) "Link"]
[(static-link) "Static link"]
[(file) "File"])
(cadr s)))
(define (status-string a default-scope)
(~a (if (ipkg-auto? a) "*" check-mark)
(if (equal? (ipkg-scope a) default-scope)
""
"!")
(case (car (ipkg-source a))
[(link static-link) "="]
[(URL) "@"]
[else ""])))
(define (scope<? a b) (define (scope<? a b)
(cond (cond
[(path? a) [(path? a)
@ -42,12 +63,22 @@
(inherit get-top-level-window) (inherit get-top-level-window)
(define filter-panel (make-filter-panel this
(lambda () (sort-list!))))
(define status-text
(new message%
[parent this]
[label install-status-desc]
[font small-control-font]
[stretchable-width #t]))
(define pkg-list (define pkg-list
(new list-box% (new list-box%
[parent this] [parent this]
[label #f] [label #f]
[choices null] [choices null]
[columns (list "Auto?" "Scope" "Name" "Checksum" "Source")] [columns (list check-mark "Scope" "Name" "Checksum" "Source")]
[style '(multiple column-headers clickable-headers)] [style '(multiple column-headers clickable-headers)]
[callback (lambda (lb e) [callback (lambda (lb e)
(when (e . is-a? . column-control-event%) (when (e . is-a? . column-control-event%)
@ -61,6 +92,12 @@
(adjust-buttons!))])) (adjust-buttons!))]))
(send pkg-list set-column-width 0 30 2 1000) (send pkg-list set-column-width 0 30 2 1000)
(send pkg-list set-column-width 2
(max 100 (let-values ([(w mn mx) (send pkg-list get-column-width 2)])
w))
2 1000)
(send pkg-list set-column-width 4 300 2 1000)
(define sort-by 0) (define sort-by 0)
(define flip? #f) (define flip? #f)
@ -190,7 +227,18 @@
'(link static-link))))))) '(link static-link)))))))
(define/private (sort-list!) (define/private (sort-list!)
(define l (sort installed (define default-scope (default-pkg-scope))
(define show-installed (let ([rx (send filter-panel get-rx)])
(filter
(lambda (a)
(or (regexp-match? rx (status-string a default-scope))
(regexp-match? rx (ipkg-name a))
(regexp-match? rx (~a (ipkg-scope a)))
(regexp-match? rx (or (ipkg-checksum a) ""))
(regexp-match? rx (source->string (ipkg-source a)))))
installed)))
(send filter-panel set-result (length show-installed) (length installed))
(define l (sort show-installed
(lambda (a b) (lambda (a b)
((if flip? not values) ((if flip? not values)
(case sort-by (case sort-by
@ -225,7 +273,7 @@
(set! sorted-installed (list->vector l)) (set! sorted-installed (list->vector l))
(send pkg-list set (send pkg-list set
(for/list ([i (in-list l)]) (for/list ([i (in-list l)])
(if (ipkg-auto? i) "*" "")) (status-string i default-scope))
(for/list ([i (in-list l)]) (for/list ([i (in-list l)])
(~a (ipkg-scope i))) (~a (ipkg-scope i)))
(for/list ([i (in-list l)]) (for/list ([i (in-list l)])
@ -233,13 +281,5 @@
(for/list ([i (in-list l)]) (for/list ([i (in-list l)])
(or (ipkg-checksum i) "")) (or (ipkg-checksum i) ""))
(for/list ([i (in-list l)]) (for/list ([i (in-list l)])
(define s (ipkg-source i)) (source->string (ipkg-source i))))
(format "~a: ~a"
(case (car s)
[(catalog) "Catalog"]
[(url) "URL"]
[(link) "Link"]
[(static-link) "Static link"]
[(file) "File"])
(cadr s))))
(adjust-buttons!)))) (adjust-buttons!))))

View File

@ -9,6 +9,7 @@
pkg/lib pkg/lib
pkg pkg
(prefix-in db: pkg/db) (prefix-in db: pkg/db)
"filter-panel.rkt"
"common.rkt") "common.rkt")
(provide by-list-panel%) (provide by-list-panel%)
@ -16,22 +17,6 @@
(define sc-pkg-update-package-list (string-constant install-pkg-update-package-list)) (define sc-pkg-update-package-list (string-constant install-pkg-update-package-list))
(define sc-pkg-stop-update (string-constant install-pkg-stop-update)) (define sc-pkg-stop-update (string-constant install-pkg-stop-update))
(define check-mark
(for/or ([c '(#\u2713 #\u2714 #\u221A #\x)])
(and (send normal-control-font screen-glyph-exists? c #t)
(string c))))
(define default-status
(~a check-mark ": installed"
" "
"*: auto-installed"
" "
"!: not default scope"
" "
"=: installed as link"
" "
"@: installed from URL"))
(define (pkg-install-status info scope default-scope) (define (pkg-install-status info scope default-scope)
(~a (cond (~a (cond
[(pkg-info-auto? info) "*"] [(pkg-info-auto? info) "*"]
@ -59,8 +44,8 @@
[alignment '(left center)] [alignment '(left center)]
[stretchable-height #f])) [stretchable-height #f]))
(define keep-rx #rx"")
(define/private (list-pkg-keep? a) (define/private (list-pkg-keep? a)
(define keep-rx (send filter-panel get-rx))
(or (regexp-match? keep-rx (db:pkg-name a)) (or (regexp-match? keep-rx (db:pkg-name a))
(regexp-match? keep-rx (db:pkg-author a)) (regexp-match? keep-rx (db:pkg-author a))
(regexp-match? keep-rx (db:pkg-desc a)) (regexp-match? keep-rx (db:pkg-desc a))
@ -68,31 +53,8 @@
(regexp-match? keep-rx (db:pkg-source a)) (regexp-match? keep-rx (db:pkg-source a))
(regexp-match? keep-rx (db:pkg-catalog a)))) (regexp-match? keep-rx (db:pkg-catalog a))))
(define filter-text (define filter-panel (make-filter-panel tool-panel
(new text-field% (lambda () (sort-pkg-list!))))
[label (~a (string-constant install-pkg-filter) ":")]
[parent tool-panel]
[font small-control-font]
[stretchable-width #t]
[callback (lambda (tf e)
(define s (send tf get-value))
(define terms (filter (lambda (s) (not (string=? s "")))
(regexp-split #rx"[, \t\r\n]" s)))
(define rx
(regexp (apply ~a
#:separator "|"
(for/list ([term terms])
(~a "(?i:" (regexp-quote term) ")")))))
(unless (equal? rx keep-rx)
(set! keep-rx rx)
(sort-pkg-list!)))]))
(define filter-result
(new message%
[label "9999/9999 match"]
[parent tool-panel]
[font small-control-font]))
(send filter-result set-label "")
(define updating? #f) (define updating? #f)
@ -110,7 +72,7 @@
(define status-text (define status-text
(new message% (new message%
[parent this] [parent this]
[label default-status] [label install-status-desc]
[font small-control-font] [font small-control-font]
[stretchable-width #t])) [stretchable-width #t]))
@ -340,7 +302,7 @@
(sync task) (sync task)
(finalize #f)) (finalize #f))
(set! task #f) (set! task #f)
(send status-text set-label default-status)) (send status-text set-label install-status-desc))
(define/private (update-db-package-list) (define/private (update-db-package-list)
(interrupt-task!) (interrupt-task!)
@ -373,7 +335,7 @@
(db:set-pkg-dependencies! name catalog (hash-ref ht 'checksum "") (db:set-pkg-dependencies! name catalog (hash-ref ht 'checksum "")
(hash-ref ht 'dependencies '()))))) (hash-ref ht 'dependencies '())))))
(lambda (finished?) (lambda (finished?)
(send status-text set-label default-status) (send status-text set-label install-status-desc)
(set! updating? #f) (set! updating? #f)
(send update-button set-label sc-pkg-update-package-list) (send update-button set-label sc-pkg-update-package-list)
(refresh-pkg-list!)))) (refresh-pkg-list!))))
@ -419,7 +381,7 @@
(send pkg-list set-string lpos (->label-string checksum) 5) (send pkg-list set-string lpos (->label-string checksum) 5)
(send pkg-list set-string lpos (->label-string source) 6))))))) (send pkg-list set-string lpos (->label-string source) 6)))))))
(lambda (ok?) (lambda (ok?)
(send status-text set-label default-status)))) (send status-text set-label install-status-desc))))
(define/private (->label-string s) (define/private (->label-string s)
(let ([s (regexp-replace* #rx"[\r\n]+" s " ")]) (let ([s (regexp-replace* #rx"[\r\n]+" s " ")])
@ -477,9 +439,7 @@
[j (in-naturals)]) [j (in-naturals)])
(vector-set! posns (cdr p) j)) (vector-set! posns (cdr p) j))
(define list-pkgs (map car list-pkg+poses)) (define list-pkgs (map car list-pkg+poses))
(send filter-result set-label (format "~a/~a match" (send filter-panel set-result (length list-pkgs) (vector-length pkgs))
(length list-pkgs)
(vector-length pkgs)))
(send pkg-list set (send pkg-list set
(for/list ([p list-pkgs]) (for/list ([p list-pkgs])
(define v (hash-ref installed (db:pkg-name p) #f)) (define v (hash-ref installed (db:pkg-name p) #f))

View File

@ -63,7 +63,8 @@
(define by-source-panel% (define by-source-panel%
(class vertical-panel% (class vertical-panel%
(init-field [in-terminal in-terminal]) (init-field [in-terminal in-terminal])
(init [text-field-initial-value #f]) (init [text-field-initial-value #f]
[(details-initially-shown? details-shown?) #f])
(super-new) (super-new)
(inherit get-top-level-window) (inherit get-top-level-window)
@ -96,7 +97,7 @@
(string-constant cancel) (string-constant cancel)
(get-top-level-window) (get-top-level-window)
'(default=1))]) '(default=1))])
(when (or (= v 3) (not v)) (esc (void))) (when (or (not v) (= v 3)) (esc (void)))
(= v 2))))) (= v 2)))))
(define f (define f
@ -125,8 +126,13 @@
[font small-control-font] [font small-control-font]
[callback browse-callback] [callback browse-callback]
[vert-margin 0])) [vert-margin 0]))
(new message%
[parent this]
[label (string-constant install-pkg-package-source-desc)]
[stretchable-width #t]
[font small-control-font])
(define/public (get-button-panel) button-panel)
(define button-panel (new horizontal-panel% (define button-panel (new horizontal-panel%
[parent this] [parent this]
[stretchable-height #f])) [stretchable-height #f]))
@ -137,6 +143,25 @@
[alignment '(left center)] [alignment '(left center)]
[stretchable-height #f])) [stretchable-height #f]))
(define/private (reset-installed-pkgs!)
(define scope (selected-scope))
(set! currently-installed-pkgs (installed-pkg-names #:scope scope))
(set! currently-installed-pkgs-scope scope))
(define details-shown? details-initially-shown?)
(define details-button (new button%
[label (if details-initially-shown?
(string-constant hide-details-button-label)
(string-constant show-details-button-label))]
[parent button-panel]
[callback
(λ (a b)
(set! details-shown? (not details-shown?))
(adjust-all))]))
(unless details-initially-shown?
(send details-parent change-children (λ (l) '())))
(new horizontal-panel% [parent button-panel])
(define ok-button (define ok-button
(new button% (new button%
[label (pick-wider normal-control-font [label (pick-wider normal-control-font
@ -161,23 +186,8 @@
(reset-installed-pkgs!) (reset-installed-pkgs!)
(adjust-all))])) (adjust-all))]))
(define/private (reset-installed-pkgs!) (define/public (get-close-button-panel) button-panel)
(define scope (selected-scope))
(set! currently-installed-pkgs (installed-pkg-names #:scope scope))
(set! currently-installed-pkgs-scope scope))
(new horizontal-panel% [parent button-panel])
(define details-shown? #f)
(define details-button (new button%
[label (string-constant show-details-button-label)]
[parent button-panel]
[callback
(λ (a b)
(set! details-shown? (not details-shown?))
(adjust-all))]))
(send details-parent change-children (λ (l) '()))
(define name-panel (new horizontal-panel% (define name-panel (new horizontal-panel%
[parent details-panel] [parent details-panel]
[stretchable-height #f])) [stretchable-height #f]))

View File

@ -8,7 +8,9 @@
(provide really-remove? (provide really-remove?
sc-install-pkg-remove sc-install-pkg-remove
pick-wider pick-wider
get-scope-list) get-scope-list
check-mark
install-status-desc)
(define sc-install-pkg-remove (string-constant install-pkg-remove)) (define sc-install-pkg-remove (string-constant install-pkg-remove))
(define really-uninstall?-msg (string-constant install-pkg-really-remove?)) (define really-uninstall?-msg (string-constant install-pkg-really-remove?))
@ -41,3 +43,19 @@
'installation 'installation
d)))) d))))
'(user))) '(user)))
(define check-mark
(for/or ([c '(#\u2713 #\u2714 #\u221A #\x)])
(and (send normal-control-font screen-glyph-exists? c #t)
(string c))))
(define install-status-desc
(~a check-mark ": installed"
" "
"*: auto-installed"
" "
"!: not default scope"
" "
"=: installed as link"
" "
"@: installed from URL"))

View File

@ -0,0 +1,50 @@
#lang racket/base
(require racket/class
racket/gui/base
racket/format
string-constants
(prefix-in db: pkg/db)
"common.rkt")
(provide make-filter-panel)
(define (make-filter-panel parent changed!)
(define filter-panel
(new horizontal-panel%
[parent parent]
[stretchable-height #f]))
(define keep-rx #rx"")
(define filter-text
(new text-field%
[label (~a (string-constant install-pkg-filter) ":")]
[parent filter-panel]
[font small-control-font]
[stretchable-width #t]
[callback (lambda (tf e)
(define s (send tf get-value))
(define terms (filter (lambda (s) (not (string=? s "")))
(regexp-split #rx"[, \t\r\n]" s)))
(define rx
(regexp (apply ~a
#:separator "|"
(for/list ([term terms])
(~a "(?i:" (regexp-quote term) ")")))))
(unless (equal? rx keep-rx)
(set! keep-rx rx)
(changed!)))]))
(define filter-result
(new message%
[label "9999/9999 match"]
[parent filter-panel]
[font small-control-font]))
(send filter-result set-label "")
(new (class object%
(super-new)
(define/public (get-rx) keep-rx)
(define/public (set-result match-count out-of-count)
(send filter-result set-label (format "~a/~a match" match-count out-of-count))))))

View File

@ -18,7 +18,7 @@
(#:wrap-terminal-action (#:wrap-terminal-action
(-> (-> any) any) (-> (-> any) any)
#:initial-tab #:initial-tab
(or/c 'by-source 'from-list 'installed 'migrate)) (or/c 'by-source 'installed 'from-list 'migrate))
(is-a?/c top-level-window<%>))] (is-a?/c top-level-window<%>))]
[make-pkg-installer [make-pkg-installer
(->* () (->* ()
@ -61,12 +61,12 @@
(when terminal (send terminal close)) (when terminal (send terminal close))
(define t (in-terminal (define t (in-terminal
#:abort-label abort-label #:abort-label abort-label
#:canvas-min-height 400 #:canvas-min-height 200
#:container dlg #:container dlg
#:close-button? #f #:close-button? #f
(λ (cust parent) (wrap-terminal-action thunk)))) (λ (cust parent) (wrap-terminal-action thunk))))
(move-close-button (send t get-button-panel))
(send dlg reflow-container) (send dlg reflow-container)
(unless parent (unless terminal (send dlg center)))
(set! terminal t) (set! terminal t)
(disallow-close) (disallow-close)
(send dlg end-container-sequence) (send dlg end-container-sequence)
@ -84,15 +84,28 @@
(define by-source-panel (define by-source-panel
(new by-source-panel% (new by-source-panel%
[parent dlg] [parent dlg]
[stretchable-height #f]
[in-terminal in-terminal-panel] [in-terminal in-terminal-panel]
[text-field-initial-value package-to-offer])) [text-field-initial-value package-to-offer]))
(define close (new button% (define close (new button%
[label (string-constant close)] [label (string-constant close)]
[parent (send by-source-panel get-button-panel)] [parent (send by-source-panel get-close-button-panel)]
[callback [callback
(λ (x y) (λ (x y)
(send dlg show #f))])) (send dlg show #f))]))
(define (move-close-button button-panel)
(define button-panel-originals (send button-panel get-children))
(send close reparent button-panel)
;; Make the close button appear in the bottom right:
(send button-panel change-children
(lambda (l)
(append
(list (new horizontal-pane% [parent button-panel]))
button-panel-originals
(list (new horizontal-pane% [parent button-panel])
close)))))
(send dlg show #t) (send dlg show #t)
@ -100,7 +113,7 @@
(define (make-pkg-gui #:wrap-terminal-action (define (make-pkg-gui #:wrap-terminal-action
[wrap-terminal-action (lambda (thunk) (thunk))] [wrap-terminal-action (lambda (thunk) (thunk))]
#:initial-tab [initial-tab 'installed]) #:initial-tab [initial-tab 'by-source])
(define frame (define frame
(new pkg-gui-frame% (new pkg-gui-frame%
@ -118,8 +131,8 @@
(new tab-panel% (new tab-panel%
[parent (send frame get-area-container)] [parent (send frame get-area-container)]
[choices (list (string-constant install-pkg-install-by-source) [choices (list (string-constant install-pkg-install-by-source)
(string-constant install-pkg-install-from-list)
(string-constant install-pkg-install-installed) (string-constant install-pkg-install-installed)
(string-constant install-pkg-install-from-list)
(string-constant install-pkg-migrate-from) (string-constant install-pkg-migrate-from)
(string-constant install-pkg-settings))] (string-constant install-pkg-settings))]
[callback (lambda (t e) [callback (lambda (t e)
@ -135,6 +148,7 @@
(send terminal close)) (send terminal close))
(define t (in-terminal (define t (in-terminal
#:abort-label abort-label #:abort-label abort-label
#:close-label (string-constant install-pkg-close-terminal-output)
#:container (send frame get-area-container) #:container (send frame get-area-container)
(λ (cust parent) (wrap-terminal-action thunk)))) (λ (cust parent) (wrap-terminal-action thunk))))
(set! terminal t) (set! terminal t)
@ -145,10 +159,10 @@
(new by-source-panel% (new by-source-panel%
[parent sel-panel] [parent sel-panel]
[in-terminal in-terminal-panel]) [in-terminal in-terminal-panel])
(new by-list-panel% (new by-installed-panel%
[parent sel-panel] [parent sel-panel]
[in-terminal in-terminal-panel]) [in-terminal in-terminal-panel])
(new by-installed-panel% (new by-list-panel%
[parent sel-panel] [parent sel-panel]
[in-terminal in-terminal-panel]) [in-terminal in-terminal-panel])
(new by-migrate-panel% (new by-migrate-panel%
@ -170,4 +184,6 @@
frame) frame)
(module+ main (module+ main
(void (make-pkg-installer))
#;
(void (make-pkg-gui))) (void (make-pkg-gui)))

View File

@ -1783,15 +1783,16 @@ please adhere to these guidelines:
(spell-program-wrote-to-stderr-on-startup "The spell program (~a) printed an error message:") (spell-program-wrote-to-stderr-on-startup "The spell program (~a) printed an error message:")
;; GUI for installing a pkg package; available via File|Install Package... ;; GUI for installing a pkg package; available via File|Install Package...
(install-pkg-install-by-source "Install by Source") ; tab label (install-pkg-install-by-source "Do What I Mean") ; tab label
(install-pkg-install-from-list "Install from List") ; tab label (install-pkg-install-from-list "Available from Catalog") ; tab label
(install-pkg-install-installed "Installed") ; tab label (install-pkg-install-installed "Currently Installed") ; tab label
(install-pkg-migrate-from "Migrate From") ; tab label (install-pkg-migrate-from "Copy from Version") ; tab label
(install-pkg-settings "Settings") ; tab label (install-pkg-settings "Settings") ; tab label
(install-pkg-menu-item... "Install Package...") (install-pkg-menu-item... "Install Package...")
(install-pkg-dialog-title "Install Package") (install-pkg-dialog-title "Install Package")
(install-pkg-source-label "Package Source") (install-pkg-source-label "Package Source")
(install-pkg-package-name "Package Name") (install-pkg-package-name "Package Name")
(install-pkg-package-source-desc "A package source is a package name, file, directory, URL, or Github reference")
(install-pkg-infer "Infer") (install-pkg-infer "Infer")
(install-pkg-use "Use") ; as opposed to "Infer", label for text box (install-pkg-use "Use") ; as opposed to "Infer", label for text box
(install-pkg-type-label "Package Source Type") (install-pkg-type-label "Package Source Type")
@ -1805,7 +1806,7 @@ please adhere to these guidelines:
(install-pkg-link-dirs "Local directory as link") (install-pkg-link-dirs "Local directory as link")
(install-pkg-file-or-dir? "Choose a file or a directory?") (install-pkg-file-or-dir? "Choose a file or a directory?")
(install-pkg-force? "Ignore conflicts") (install-pkg-force? "Ignore conflicts")
(install-pkg-replace? "Replace existing installation") (install-pkg-replace? "Updates can replace existing installations")
(install-pkg-command-line "Equivalent command line invocation:") (install-pkg-command-line "Equivalent command line invocation:")
(install-pkg-error-installing-title "Error Installing Package") (install-pkg-error-installing-title "Error Installing Package")
(install-pkg-action-label "Action to Take") (install-pkg-action-label "Action to Take")
@ -1842,6 +1843,7 @@ please adhere to these guidelines:
(install-pkg-abort-promote "Abort Promote") (install-pkg-abort-promote "Abort Promote")
(install-pkg-abort-migrate "Abort Migrate") (install-pkg-abort-migrate "Abort Migrate")
(install-pkg-abort-generic-action "Abort Action") (install-pkg-abort-generic-action "Abort Action")
(install-pkg-close-terminal-output "Close Output")
(install-pkg-show-all-options "Show All Options") (install-pkg-show-all-options "Show All Options")
(install-pkg-migrate-available-installations "Available Installations") (install-pkg-migrate-available-installations "Available Installations")
(pkg-manager-menu-item "Package Manager...") (pkg-manager-menu-item "Package Manager...")

View File

@ -1658,10 +1658,10 @@
(spell-program-wrote-to-stderr-on-startup "Der Rechtschreibchecker (~a) hat eine Fehlermeldung ausgegeben:") (spell-program-wrote-to-stderr-on-startup "Der Rechtschreibchecker (~a) hat eine Fehlermeldung ausgegeben:")
;; GUI for installing a pkg package; available via File|Install Package... ;; GUI for installing a pkg package; available via File|Install Package...
(install-pkg-install-by-source "Nach Quelle installieren") ; tab label ; change: (install-pkg-install-by-source "Nach Quelle installieren") ; tab label
(install-pkg-install-from-list "Von Liste installieren") ; tab label ; change: (install-pkg-install-from-list "Von Liste installieren") ; tab label
(install-pkg-install-installed "Installiert") ; tab label ; change: (install-pkg-install-installed "Installiert") ; tab label
(install-pkg-migrate-from "Migrieren von") ; tab label ; change: (install-pkg-migrate-from "Migrieren von") ; tab label
(install-pkg-menu-item... "Paket installieren...") (install-pkg-menu-item... "Paket installieren...")
(install-pkg-dialog-title "Paket installieren") (install-pkg-dialog-title "Paket installieren")
(install-pkg-source-label "Packet-Quelltext") (install-pkg-source-label "Packet-Quelltext")