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

GUI package manager: further refinements

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-installed.rkt
View File

@ -6,6 +6,7 @@
pkg/lib
pkg
string-constants
"filter-panel.rkt"
"common.rkt")
(provide by-installed-panel%)
@ -18,6 +19,26 @@
(path->string (path->complete-path s dir))
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)
(cond
[(path? a)
@ -42,12 +63,22 @@
(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
(new list-box%
[parent this]
[label #f]
[choices null]
[columns (list "Auto?" "Scope" "Name" "Checksum" "Source")]
[columns (list check-mark "Scope" "Name" "Checksum" "Source")]
[style '(multiple column-headers clickable-headers)]
[callback (lambda (lb e)
(when (e . is-a? . column-control-event%)
@ -61,6 +92,12 @@
(adjust-buttons!))]))
(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 flip? #f)
@ -190,7 +227,18 @@
'(link static-link)))))))
(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)
((if flip? not values)
(case sort-by
@ -225,7 +273,7 @@
(set! sorted-installed (list->vector l))
(send pkg-list set
(for/list ([i (in-list l)])
(if (ipkg-auto? i) "*" ""))
(status-string i default-scope))
(for/list ([i (in-list l)])
(~a (ipkg-scope i)))
(for/list ([i (in-list l)])
@ -233,13 +281,5 @@
(for/list ([i (in-list l)])
(or (ipkg-checksum i) ""))
(for/list ([i (in-list l)])
(define s (ipkg-source i))
(format "~a: ~a"
(case (car s)
[(catalog) "Catalog"]
[(url) "URL"]
[(link) "Link"]
[(static-link) "Static link"]
[(file) "File"])
(cadr s))))
(source->string (ipkg-source i))))
(adjust-buttons!))))

58
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-list.rkt
View File

@ -9,6 +9,7 @@
pkg/lib
pkg
(prefix-in db: pkg/db)
"filter-panel.rkt"
"common.rkt")
(provide by-list-panel%)
@ -16,22 +17,6 @@
(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 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)
(~a (cond
[(pkg-info-auto? info) "*"]
@ -59,8 +44,8 @@
[alignment '(left center)]
[stretchable-height #f]))
(define keep-rx #rx"")
(define/private (list-pkg-keep? a)
(define keep-rx (send filter-panel get-rx))
(or (regexp-match? keep-rx (db:pkg-name a))
(regexp-match? keep-rx (db:pkg-author 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-catalog a))))
(define filter-text
(new text-field%
[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 filter-panel (make-filter-panel tool-panel
(lambda () (sort-pkg-list!))))
(define updating? #f)
@ -110,7 +72,7 @@
(define status-text
(new message%
[parent this]
[label default-status]
[label install-status-desc]
[font small-control-font]
[stretchable-width #t]))
@ -340,7 +302,7 @@
(sync task)
(finalize #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)
(interrupt-task!)
@ -373,7 +335,7 @@
(db:set-pkg-dependencies! name catalog (hash-ref ht 'checksum "")
(hash-ref ht 'dependencies '())))))
(lambda (finished?)
(send status-text set-label default-status)
(send status-text set-label install-status-desc)
(set! updating? #f)
(send update-button set-label sc-pkg-update-package-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 source) 6)))))))
(lambda (ok?)
(send status-text set-label default-status))))
(send status-text set-label install-status-desc))))
(define/private (->label-string s)
(let ([s (regexp-replace* #rx"[\r\n]+" s " ")])
@ -477,9 +439,7 @@
[j (in-naturals)])
(vector-set! posns (cdr p) j))
(define list-pkgs (map car list-pkg+poses))
(send filter-result set-label (format "~a/~a match"
(length list-pkgs)
(vector-length pkgs)))
(send filter-panel set-result (length list-pkgs) (vector-length pkgs))
(send pkg-list set
(for/list ([p list-pkgs])
(define v (hash-ref installed (db:pkg-name p) #f))

48
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-source.rkt
View File

@ -63,7 +63,8 @@
(define by-source-panel%
(class vertical-panel%
(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)
(inherit get-top-level-window)
@ -96,7 +97,7 @@
(string-constant cancel)
(get-top-level-window)
'(default=1))])
(when (or (= v 3) (not v)) (esc (void)))
(when (or (not v) (= v 3)) (esc (void)))
(= v 2)))))
(define f
@ -125,8 +126,13 @@
[font small-control-font]
[callback browse-callback]
[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%
[parent this]
[stretchable-height #f]))
@ -137,6 +143,25 @@
[alignment '(left center)]
[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
(new button%
[label (pick-wider normal-control-font
@ -161,23 +186,8 @@
(reset-installed-pkgs!)
(adjust-all))]))
(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/public (get-close-button-panel) button-panel)
(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%
[parent details-panel]
[stretchable-height #f]))

20
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/common.rkt
View File

@ -8,7 +8,9 @@
(provide really-remove?
sc-install-pkg-remove
pick-wider
get-scope-list)
get-scope-list
check-mark
install-status-desc)
(define sc-install-pkg-remove (string-constant install-pkg-remove))
(define really-uninstall?-msg (string-constant install-pkg-really-remove?))
@ -41,3 +43,19 @@
'installation
d))))
'(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"))

50
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/filter-panel.rkt Normal file
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))))))

32
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/main.rkt
View File

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

14
pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
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:")
;; GUI for installing a pkg package; available via File|Install Package...
(install-pkg-install-by-source "Install by Source") ; tab label
(install-pkg-install-from-list "Install from List") ; tab label
(install-pkg-install-installed "Installed") ; tab label
(install-pkg-migrate-from "Migrate From") ; tab label
(install-pkg-settings "Settings") ; tab label
(install-pkg-install-by-source "Do What I Mean") ; tab label
(install-pkg-install-from-list "Available from Catalog") ; tab label
(install-pkg-install-installed "Currently Installed") ; tab label
(install-pkg-migrate-from "Copy from Version") ; tab label
(install-pkg-settings "Settings") ; tab label
(install-pkg-menu-item... "Install Package...")
(install-pkg-dialog-title "Install Package")
(install-pkg-source-label "Package Source")
(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-use "Use") ; as opposed to "Infer", label for text box
(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-file-or-dir? "Choose a file or a directory?")
(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-error-installing-title "Error Installing Package")
(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-migrate "Abort Migrate")
(install-pkg-abort-generic-action "Abort Action")
(install-pkg-close-terminal-output "Close Output")
(install-pkg-show-all-options "Show All Options")
(install-pkg-migrate-available-installations "Available Installations")
(pkg-manager-menu-item "Package Manager...")

8
pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt
View File

@ -1658,10 +1658,10 @@
(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...
(install-pkg-install-by-source "Nach Quelle installieren") ; tab label
(install-pkg-install-from-list "Von Liste installieren") ; tab label
(install-pkg-install-installed "Installiert") ; tab label
(install-pkg-migrate-from "Migrieren von") ; tab label
; change: (install-pkg-install-by-source "Nach Quelle installieren") ; tab label
; change: (install-pkg-install-from-list "Von Liste installieren") ; tab label
; change: (install-pkg-install-installed "Installiert") ; tab label
; change: (install-pkg-migrate-from "Migrieren von") ; tab label
(install-pkg-menu-item... "Paket installieren...")
(install-pkg-dialog-title "Paket installieren")
(install-pkg-source-label "Packet-Quelltext")