GUI package manager: fill in functionality
Add supoprt for various operations that became available in the command-line interface.
This commit is contained in:
Matthew Flatt
parent
c0af1fe4bd
commit
83a813b1e5
|
|
@ -2,6 +2,7 @@
|
|||
(require racket/class
|
||||
racket/gui/base
|
||||
racket/format
|
||||
setup/dirs
|
||||
pkg/lib
|
||||
pkg
|
||||
string-constants
|
||||
|
|
@ -11,6 +12,12 @@
|
|||
|
||||
(struct ipkg (name scope auto? checksum source))
|
||||
|
||||
(define ((ipkg->source dir) ipkg)
|
||||
(define s (cadr (ipkg-source ipkg)))
|
||||
(if (not (eq? 'catalog (car (ipkg-source ipkg))))
|
||||
(path->string (path->complete-path s dir))
|
||||
s))
|
||||
|
||||
(define (scope<? a b)
|
||||
(cond
|
||||
[(path? a)
|
||||
|
|
@ -81,70 +88,130 @@
|
|||
[alignment '(center center)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(define remove-button
|
||||
(new button%
|
||||
[label sc-install-pkg-remove]
|
||||
[parent button-line]
|
||||
[callback (lambda (b e)
|
||||
(define ipkgs (selected-ipkgs))
|
||||
(define names (map ipkg-name ipkgs))
|
||||
(when (really-remove? names #:parent (get-top-level-window))
|
||||
(define scope (ipkg-scope (car ipkgs)))
|
||||
(in-terminal
|
||||
(string-constant install-pkg-abort-remove)
|
||||
(lambda ()
|
||||
(apply
|
||||
pkg-remove-command
|
||||
#:scope scope
|
||||
names)))
|
||||
(reset-installed-list!)))]))
|
||||
|
||||
(define update-button
|
||||
(new button%
|
||||
[label (string-constant install-pkg-update)]
|
||||
[parent button-line]
|
||||
[callback (lambda (b e)
|
||||
(define ipkgs (selected-ipkgs))
|
||||
(define names (map ipkg-name ipkgs))
|
||||
(define scope (ipkg-scope (car ipkgs)))
|
||||
(in-terminal
|
||||
(handle-packages
|
||||
(string-constant install-pkg-abort-update)
|
||||
(lambda ()
|
||||
(lambda (names scope)
|
||||
(apply
|
||||
pkg-update-command
|
||||
#:scope scope
|
||||
names)))
|
||||
(reset-installed-list!))]))
|
||||
names))))]))
|
||||
|
||||
(define promote-button
|
||||
(new button%
|
||||
[label (string-constant install-pkg-promote)]
|
||||
[parent button-line]
|
||||
[callback (lambda (b e)
|
||||
(handle-packages
|
||||
(string-constant install-pkg-abort-promote)
|
||||
#:ipkgs? #t
|
||||
(lambda (ipkgs scope)
|
||||
;; Links can be relative to scope:
|
||||
(define dir (cond
|
||||
[(path? scope) scope]
|
||||
[(eq? scope 'installation) (find-pkgs-dir)]
|
||||
[else (find-user-pkgs-dir)]))
|
||||
;; Also preserve link kind:
|
||||
(define kind (car (ipkg-source (car ipkgs))))
|
||||
(apply
|
||||
pkg-install-command
|
||||
#:scope scope
|
||||
#:link (eq? 'link kind)
|
||||
#:static-link (eq? 'static-link kind)
|
||||
(map (ipkg->source dir) ipkgs)))))]))
|
||||
|
||||
(define demote-button
|
||||
(new button%
|
||||
[label (string-constant install-pkg-demote)]
|
||||
[parent button-line]
|
||||
[callback (lambda (b e)
|
||||
(handle-packages
|
||||
(string-constant install-pkg-abort-demote)
|
||||
(lambda (names scope)
|
||||
(apply
|
||||
pkg-remove-command
|
||||
#:demote #t
|
||||
#:scope scope
|
||||
names))))]))
|
||||
|
||||
(define remove-button
|
||||
(new button%
|
||||
[label sc-install-pkg-remove]
|
||||
[parent button-line]
|
||||
[callback (lambda (b e)
|
||||
(handle-packages
|
||||
(string-constant install-pkg-abort-remove)
|
||||
#:check (lambda (names)
|
||||
(really-remove? names #:parent (get-top-level-window)))
|
||||
(lambda (names scope)
|
||||
(apply
|
||||
pkg-remove-command
|
||||
#:scope scope
|
||||
names))))]))
|
||||
|
||||
(define/private (handle-packages label cb
|
||||
#:ipkgs? [ipkgs? #f]
|
||||
#:check [check void])
|
||||
(define ipkgs (selected-ipkgs))
|
||||
(define names (map ipkg-name ipkgs))
|
||||
(when (check names)
|
||||
(define scope (ipkg-scope (car ipkgs)))
|
||||
(in-terminal
|
||||
label
|
||||
(lambda ()
|
||||
(cb (if ipkgs? ipkgs names) scope)))
|
||||
(reset-installed-list!)))
|
||||
|
||||
(define/private (adjust-buttons!)
|
||||
(define ipkgs (selected-ipkgs))
|
||||
(define same-scope? (and (pair? ipkgs)
|
||||
;; must be all in the same scope:
|
||||
(for/and ([i (cdr ipkgs)])
|
||||
(for/and ([i (in-list (cdr ipkgs))])
|
||||
(equal? (ipkg-scope i) (ipkg-scope (car ipkgs))))))
|
||||
(send remove-button enable same-scope?)
|
||||
(send demote-button enable (and same-scope?
|
||||
(for/and ([i (in-list ipkgs)])
|
||||
(not (ipkg-auto? i)))))
|
||||
(send promote-button enable (and same-scope?
|
||||
(for/and ([i (in-list ipkgs)])
|
||||
(ipkg-auto? i))
|
||||
;; all 'catalog, 'link, or 'static-link
|
||||
(let ([kind (car (ipkg-source (car ipkgs)))])
|
||||
(and (memq kind '(catalog link static-link))
|
||||
(for/and ([i (in-list (cdr ipkgs))])
|
||||
(eq? kind (car (ipkg-source i))))))))
|
||||
(send update-button enable (and same-scope?
|
||||
(for/and ([i (in-list ipkgs)])
|
||||
(not (eq? 'link (car (ipkg-source i))))))))
|
||||
(not (memq (car (ipkg-source i))
|
||||
'(link static-link)))))))
|
||||
|
||||
(define/private (sort-list!)
|
||||
(define l (sort installed
|
||||
(lambda (a b)
|
||||
((if flip? not values)
|
||||
(case sort-by
|
||||
[(0) (if (equal? (ipkg-scope a) (ipkg-scope b))
|
||||
[(0) (if (eq? (ipkg-auto? a) (ipkg-auto? b))
|
||||
(if (equal? (ipkg-scope a) (ipkg-scope b))
|
||||
(string<? (ipkg-name a) (ipkg-name b))
|
||||
(not (ipkg-auto? a)))
|
||||
(ipkg-auto? b))]
|
||||
[(1) (if (equal? (ipkg-scope a) (ipkg-scope b))
|
||||
(if (eq? (ipkg-auto? a) (ipkg-auto? b))
|
||||
(string<? (ipkg-name a) (ipkg-name b))
|
||||
(not (ipkg-auto? a)))
|
||||
(scope<? (ipkg-scope a) (ipkg-scope b)))]
|
||||
[(1) (ipkg<? a b)]
|
||||
[(2) (if (equal? (ipkg-checksum a) (ipkg-checksum b))
|
||||
[(2) (ipkg<? a b)]
|
||||
[(3) (if (equal? (ipkg-checksum a) (ipkg-checksum b))
|
||||
(ipkg<? a b)
|
||||
(cond
|
||||
[(not (ipkg-checksum a)) #f]
|
||||
[(not (ipkg-checksum b)) #t]
|
||||
[else (string<? (ipkg-checksum a) (ipkg-checksum b))]))]
|
||||
[(3)
|
||||
[(4)
|
||||
(define sa (ipkg-source a))
|
||||
(define sb (ipkg-source b))
|
||||
(if (equal? sa sb)
|
||||
|
|
|
|||
|
|
@ -32,6 +32,19 @@
|
|||
" "
|
||||
"@: installed from URL"))
|
||||
|
||||
(define (pkg-install-status info scope default-scope)
|
||||
(~a (cond
|
||||
[(pkg-info-auto? info) "*"]
|
||||
[else check-mark])
|
||||
(cond
|
||||
[(equal? scope default-scope) ""]
|
||||
[else "!"])
|
||||
(case (car (pkg-info-orig-pkg info))
|
||||
[(catalog) ""]
|
||||
[(link) "="]
|
||||
[(static-link) "="]
|
||||
[(url) "@"])))
|
||||
|
||||
(define by-list-panel%
|
||||
(class vertical-panel%
|
||||
(init-field [in-terminal in-terminal])
|
||||
|
|
@ -106,13 +119,20 @@
|
|||
|
||||
(define/private (sort-by! col)
|
||||
(define sel (case col
|
||||
[(0 1) db:pkg-name]
|
||||
[(0) (lambda (p)
|
||||
(define i
|
||||
(hash-ref installed (db:pkg-name p) #f))
|
||||
(if i
|
||||
(pkg-install-status (cdr i) (car i) default-scope)
|
||||
""))]
|
||||
[(1) db:pkg-name]
|
||||
[(2) db:pkg-author]
|
||||
[(3) db:pkg-desc]
|
||||
[(4) (lambda (p) (format-tags (pkg-tags p)))]
|
||||
[(5) db:pkg-checksum]
|
||||
[(6) db:pkg-source]
|
||||
[(7) db:pkg-catalog]))
|
||||
(define empty-last? (not (= col 0)))
|
||||
(define switch (if (= sort-column col)
|
||||
not
|
||||
values))
|
||||
|
|
@ -123,10 +143,12 @@
|
|||
(lambda (a b)
|
||||
(switch
|
||||
(cond
|
||||
[(and (not (string=? (sel a) ""))
|
||||
[(and empty-last?
|
||||
(not (string=? (sel a) ""))
|
||||
(string=? (sel b) ""))
|
||||
#t]
|
||||
[(and (string=? (sel a) "")
|
||||
[(and empty-last?
|
||||
(string=? (sel a) "")
|
||||
(not (string=? (sel b) "")))
|
||||
#f]
|
||||
[(string<? (sel a) (sel b)) #t]
|
||||
|
|
@ -419,17 +441,19 @@
|
|||
(set! tagss (for/hash ([p (in-list pkg-list)]
|
||||
[t (in-list tags-list)])
|
||||
(values p t)))
|
||||
(set! default-scope (default-pkg-scope))
|
||||
(refresh-installed-list! #:always? #t))
|
||||
|
||||
(define/private (refresh-installed-list! #:always? [always? #f])
|
||||
(define new-default-scope (default-pkg-scope))
|
||||
(define new-installed
|
||||
(for*/hash ([scope (in-list (get-scope-list))]
|
||||
[(k v) (in-hash (installed-pkg-table #:scope scope))])
|
||||
(values k (cons scope v))))
|
||||
(when (or always?
|
||||
(not (equal? installed new-installed)))
|
||||
(not (equal? installed new-installed))
|
||||
(not (eq? default-scope new-default-scope)))
|
||||
(set! installed new-installed)
|
||||
(set! default-scope new-default-scope)
|
||||
(sort-pkg-list!)))
|
||||
|
||||
(define/private (pkg-tags p)
|
||||
|
|
@ -462,18 +486,7 @@
|
|||
(cond
|
||||
[(not v) ""]
|
||||
[else
|
||||
(define info (cdr v))
|
||||
(~a (cond
|
||||
[(pkg-info-auto? info) "*"]
|
||||
[else check-mark])
|
||||
(cond
|
||||
[(equal? (car v) default-scope) ""]
|
||||
[else "!"])
|
||||
(case (car (pkg-info-orig-pkg info))
|
||||
[(catalog) ""]
|
||||
[(link) "="]
|
||||
[(static-link) "="]
|
||||
[(url) "@"]))]))
|
||||
(pkg-install-status (cdr v) (car v) default-scope)]))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-name p)))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-author p)))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-desc p)))
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@
|
|||
(define sc-install-pkg-dependencies-fail (string-constant install-pkg-dependencies-fail))
|
||||
(define sc-install-pkg-dependencies-force (string-constant install-pkg-dependencies-force))
|
||||
(define sc-install-pkg-dependencies-search-ask (string-constant install-pkg-dependencies-search-ask))
|
||||
(define sc-install-pkg-dependencies-search-auto
|
||||
(string-constant install-pkg-dependencies-search-auto))
|
||||
(define sc-install-pkg-dependencies-search-auto (string-constant install-pkg-dependencies-search-auto))
|
||||
(define sc-install-pkg-dependencies-search-auto+update (string-constant install-pkg-dependencies-search-auto+update))
|
||||
|
||||
(define sc-install-pkg-dependencies-mode (string-constant install-pkg-dependencies-mode))
|
||||
|
||||
|
|
@ -83,32 +83,47 @@
|
|||
(preferences:get 'drracket:gui-installer-pkg-source)))
|
||||
|
||||
(define (browse-callback b e)
|
||||
(define mode (send choice get-string-selection))
|
||||
(define dir? (or (equal? mode sc-install-pkg-dir)
|
||||
(equal? mode sc-install-pkg-dir-url)))
|
||||
(define f
|
||||
(cond
|
||||
[dir?
|
||||
(get-directory (string-constant install-pkg-select-package-directory)
|
||||
(get-top-level-window))]
|
||||
[else
|
||||
(parameterize ([finder:default-filters
|
||||
'(("Package" "*.zip;*.plt;*.tgz;*.tar")
|
||||
("Any" "*.*"))])
|
||||
(finder:get-file #f (string-constant install-pkg-select-package-file)
|
||||
#f "bad"
|
||||
(get-top-level-window)))]))
|
||||
(when f
|
||||
(send tf set-value
|
||||
(url->string (path->url (if dir?
|
||||
(path->directory-path f)
|
||||
f))))
|
||||
(adjust-all)))
|
||||
(let/ec esc
|
||||
(define mode (send choice get-string-selection))
|
||||
(define dir? (or (equal? mode sc-install-pkg-dir)
|
||||
(and (not (equal? mode sc-install-pkg-file))
|
||||
(let ([v (message-box/custom
|
||||
(string-constant browse...)
|
||||
(string-constant install-pkg-file-or-dir?)
|
||||
(string-constant install-pkg-file)
|
||||
(string-constant install-pkg-dir)
|
||||
(string-constant cancel)
|
||||
(get-top-level-window)
|
||||
'(default=1))])
|
||||
(when (or (= v 3) (not v)) (esc (void)))
|
||||
(= v 2)))))
|
||||
|
||||
(define f
|
||||
(cond
|
||||
[dir?
|
||||
(get-directory (string-constant install-pkg-select-package-directory)
|
||||
(get-top-level-window))]
|
||||
[else
|
||||
(parameterize ([finder:default-filters
|
||||
'(("Package" "*.zip;*.plt;*.tgz;*.tar")
|
||||
("Any" "*.*"))])
|
||||
(finder:get-file #f (string-constant install-pkg-select-package-file)
|
||||
#f "bad"
|
||||
(get-top-level-window)))]))
|
||||
(when f
|
||||
(send tf set-value
|
||||
;; Simplified paths on no platform should start "[a-z]*://":
|
||||
(path->string (simplify-path
|
||||
(if dir?
|
||||
(path->directory-path f)
|
||||
f))))
|
||||
(adjust-all))))
|
||||
(define browse-button (new button%
|
||||
[parent source-panel]
|
||||
[label (string-constant browse...)]
|
||||
[font small-control-font]
|
||||
[callback browse-callback]))
|
||||
[callback browse-callback]
|
||||
[vert-margin 0]))
|
||||
|
||||
(define/public (get-button-panel) button-panel)
|
||||
(define button-panel (new horizontal-panel%
|
||||
|
|
@ -159,9 +174,35 @@
|
|||
(adjust-all))]))
|
||||
|
||||
(send details-parent change-children (λ (l) '()))
|
||||
|
||||
(define name-panel (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
[stretchable-height #f]))
|
||||
(define name-choice (new radio-box%
|
||||
[label (~a (string-constant install-pkg-package-name) ":")]
|
||||
[parent name-panel]
|
||||
[style '(horizontal)]
|
||||
[stretchable-width #f]
|
||||
[choices (list (string-constant install-pkg-infer)
|
||||
(~a (string-constant install-pkg-use) ":"))]
|
||||
[callback (lambda (cb e) (adjust-all))]))
|
||||
(define name-message (new message%
|
||||
[label ""]
|
||||
[parent name-panel]
|
||||
[stretchable-width #t]))
|
||||
(define name-field (new text-field%
|
||||
[label #f]
|
||||
[parent name-panel]))
|
||||
;; Make the panel height the same whether we show the message or field:
|
||||
(let-values ([(w h) (send name-panel get-graphical-min-size)])
|
||||
(send name-panel min-height h))
|
||||
|
||||
(define type-panel (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
[stretchable-height #f]))
|
||||
(define choice (new choice%
|
||||
[label (~a sc-install-pkg-type-label ":")]
|
||||
[parent details-panel]
|
||||
[parent type-panel]
|
||||
[stretchable-width #t]
|
||||
[callback (λ (x y) (adjust-all))]
|
||||
[choices (list sc-install-pkg-infer
|
||||
|
|
@ -171,6 +212,11 @@
|
|||
sc-install-pkg-dir-url
|
||||
sc-install-pkg-github
|
||||
sc-install-pkg-name)]))
|
||||
(define link-dir-checkbox (new check-box%
|
||||
[parent type-panel]
|
||||
[label (string-constant install-pkg-link-dirs)]
|
||||
[value #t]
|
||||
[callback (lambda (b e) (adjust-cmd-line))]))
|
||||
|
||||
(define inferred-msg-parent (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
|
|
@ -213,6 +259,7 @@
|
|||
(define scope-default-button (new button%
|
||||
[label sc-install-pkg-set-as-default]
|
||||
[font small-control-font]
|
||||
[vert-margin 0]
|
||||
[parent scope-panel]
|
||||
[callback
|
||||
(lambda (b e)
|
||||
|
|
@ -220,7 +267,7 @@
|
|||
sc-install-pkg-abort-set-scope
|
||||
(lambda ()
|
||||
(define scope (selected-scope))
|
||||
(pkg-config-command #:scope 'installation
|
||||
(pkg-config-command #:scope 'user
|
||||
#:set #t
|
||||
"default-scope"
|
||||
(~a scope))
|
||||
|
|
@ -252,7 +299,8 @@
|
|||
sc-install-pkg-dependencies-fail
|
||||
sc-install-pkg-dependencies-force
|
||||
sc-install-pkg-dependencies-search-ask
|
||||
sc-install-pkg-dependencies-search-auto)]
|
||||
sc-install-pkg-dependencies-search-auto
|
||||
sc-install-pkg-dependencies-search-auto+update)]
|
||||
[stretchable-width #t]
|
||||
[callback deps-choice-callback]))
|
||||
(define deps-msg-parent (new horizontal-panel%
|
||||
|
|
@ -313,10 +361,20 @@
|
|||
'install])]
|
||||
[(1) 'install]
|
||||
[(2) 'update]))
|
||||
|
||||
|
||||
|
||||
(define/private (infer-package-name?)
|
||||
(= 0 (send name-choice get-selection)))
|
||||
|
||||
(define/private (get-name)
|
||||
(if (infer-package-name?)
|
||||
(or (package-source->name (send tf get-value) (selected-type))
|
||||
"???")
|
||||
(send name-field get-value)))
|
||||
|
||||
(define/private (adjust-all)
|
||||
(adjust-name)
|
||||
(adjust-inferred)
|
||||
(adjust-link-dir)
|
||||
(adjust-inferred-action)
|
||||
(adjust-checkbox)
|
||||
(adjust-cmd-line)
|
||||
|
|
@ -325,6 +383,17 @@
|
|||
(adjust-scope)
|
||||
(adjust-deps)
|
||||
(adjust-ok))
|
||||
|
||||
(define/private (adjust-name)
|
||||
(define infer? (infer-package-name?))
|
||||
(send name-panel change-children
|
||||
(lambda (l)
|
||||
(list name-choice
|
||||
(if infer? name-message name-field))))
|
||||
(when infer?
|
||||
(define name (get-name))
|
||||
(send name-message set-label name)
|
||||
(send name-field set-value name)))
|
||||
|
||||
(define/private (adjust-checkbox)
|
||||
(send cb enable (equal? 'install (get-current-action))))
|
||||
|
|
@ -348,8 +417,9 @@
|
|||
|
||||
(define/private (adjust-browse)
|
||||
(define mode (send choice get-string-selection))
|
||||
(define show? (not (or (equal? mode sc-install-pkg-github)
|
||||
(equal? mode sc-install-pkg-name))))
|
||||
(define show? (or (equal? mode sc-install-pkg-infer)
|
||||
(equal? mode sc-install-pkg-file)
|
||||
(equal? mode sc-install-pkg-dir)))
|
||||
(define shown? (member browse-button (send source-panel get-children)))
|
||||
(unless (eq? (and show? #t) (and shown? #t))
|
||||
(if show?
|
||||
|
|
@ -378,6 +448,9 @@
|
|||
(and inferred-actual-type
|
||||
(format sc-install-pkg-inferred-as (type->str inferred-actual-type))))
|
||||
(send inferred-msg set-label (or new-lab "")))
|
||||
|
||||
(define/private (adjust-link-dir)
|
||||
(send link-dir-checkbox show (member (selected-type) '(#f dir))))
|
||||
|
||||
(define (get-inferred-actual-type)
|
||||
(and (equal? #f (selected-type))
|
||||
|
|
@ -405,7 +478,14 @@
|
|||
(send deps-msg set-label
|
||||
(cond
|
||||
[(equal? 0 (send deps-choice get-selection))
|
||||
(format sc-install-pkg-deps-is (get-deps-selected-type))]
|
||||
(format sc-install-pkg-deps-is
|
||||
(cadr
|
||||
(regexp-match #rx"^(.*):"
|
||||
(case (get-deps-selected-type)
|
||||
[(fail)
|
||||
(string-constant install-pkg-dependencies-fail)]
|
||||
[(search-auto)
|
||||
(string-constant install-pkg-dependencies-search-auto)]))))]
|
||||
[else ""])))
|
||||
|
||||
(define (get-deps-selected-type)
|
||||
|
|
@ -418,7 +498,10 @@
|
|||
[(1) 'fail]
|
||||
[(2) 'force]
|
||||
[(3) 'fail] ;; shouldn't happen
|
||||
[(4) 'search-auto]))
|
||||
[(4 5) 'search-auto]))
|
||||
|
||||
(define (get-deps-auto-update)
|
||||
(= 5 (send deps-choice get-selection)))
|
||||
|
||||
(define/private (adjust-cmd-line)
|
||||
(define (possibly-quote-string s)
|
||||
|
|
@ -438,9 +521,10 @@
|
|||
string-append
|
||||
(add-between
|
||||
(map (λ (kwd kwd-arg)
|
||||
(format "--~a ~s"
|
||||
(regexp-replace #rx"^#:" (format "~a" kwd) "")
|
||||
kwd-arg))
|
||||
(define flag (~a "--" (keyword->string kwd)))
|
||||
(if (boolean? kwd-arg)
|
||||
flag
|
||||
(~a flag " " (~s kwd-arg))))
|
||||
(cmdline-kwds cmd-line)
|
||||
(cmdline-kwd-args cmd-line))
|
||||
" "))
|
||||
|
|
@ -470,10 +554,17 @@
|
|||
(add-kwd-arg '#:force #t))
|
||||
(when (selected-type)
|
||||
(add-kwd-arg '#:type (selected-type)))
|
||||
(when (send link-dir-checkbox get-value)
|
||||
(when (eq? 'dir (or (selected-type) (get-inferred-actual-type)))
|
||||
(add-kwd-arg '#:link #t)))
|
||||
(let ([scope (selected-scope)])
|
||||
(unless (equal? scope (default-pkg-scope))
|
||||
(add-kwd-arg '#:scope scope)))
|
||||
(add-kwd-arg '#:deps (get-deps-selected-type))
|
||||
(when (get-deps-auto-update)
|
||||
(add-kwd-arg '#:update-deps #t))
|
||||
(unless (infer-package-name?)
|
||||
(add-kwd-arg '#:name (get-name)))
|
||||
(cmdline (get-current-action) kwds kwd-args (list the-pkg))]))
|
||||
|
||||
(define/override (on-superwindow-show on?)
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
"by-list.rkt"
|
||||
"by-installed.rkt"
|
||||
"by-migrate.rkt"
|
||||
"settings.rkt"
|
||||
mrlib/terminal
|
||||
string-constants)
|
||||
|
||||
|
|
@ -119,7 +120,8 @@
|
|||
[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-migrate-from))]
|
||||
(string-constant install-pkg-migrate-from)
|
||||
(string-constant install-pkg-settings))]
|
||||
[callback (lambda (t e)
|
||||
(update-sel-panel-active))]))
|
||||
|
||||
|
|
@ -152,6 +154,8 @@
|
|||
(new by-migrate-panel%
|
||||
[parent sel-panel]
|
||||
[in-terminal in-terminal-panel])
|
||||
(new settings-panel%
|
||||
[parent sel-panel])
|
||||
|
||||
(send sel-tab set-selection
|
||||
(case initial-tab
|
||||
|
|
|
|||
|
|
@ -0,0 +1,164 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
racket/format
|
||||
racket/list
|
||||
racket/file
|
||||
string-constants
|
||||
setup/dirs
|
||||
pkg/lib
|
||||
net/url
|
||||
"common.rkt")
|
||||
|
||||
(provide settings-panel%)
|
||||
|
||||
(define settings-panel%
|
||||
(class vertical-panel%
|
||||
(super-new [alignment '(left center)])
|
||||
|
||||
(inherit get-top-level-window)
|
||||
|
||||
(define scope-choice
|
||||
(new choice%
|
||||
[label (~a (string-constant install-pkg-default-scope-label)
|
||||
":")]
|
||||
[parent this]
|
||||
[callback (λ (c y)
|
||||
(catch-errors
|
||||
(lambda ()
|
||||
(parameterize ([current-pkg-scope 'user])
|
||||
(with-pkg-lock
|
||||
(pkg-config #t (list "default-scope"
|
||||
(if (= 0 (send c get-selection))
|
||||
"installation"
|
||||
"user")))))))
|
||||
(adjust-all))]
|
||||
[choices (list (string-constant install-pkg-installation)
|
||||
(string-constant install-pkg-user))]))
|
||||
|
||||
(define catalog-panel
|
||||
(new horizontal-panel%
|
||||
[parent this]
|
||||
[alignment '(center top)]))
|
||||
|
||||
(define catalog-list
|
||||
(new list-box%
|
||||
[label (~a (string-constant install-pkg-package-catalogs) ":")]
|
||||
[parent catalog-panel]
|
||||
[callback (lambda (x y) (adjust-buttons))]
|
||||
[choices null]))
|
||||
|
||||
(define button-panel (new vertical-panel%
|
||||
[parent catalog-panel]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #f]
|
||||
[alignment '(center top)]))
|
||||
|
||||
(define raise-button (new button%
|
||||
[parent button-panel]
|
||||
[label (string-constant ml-cp-raise)]
|
||||
[callback (lambda (b e)
|
||||
(adjust-catalogs
|
||||
(lambda (l n)
|
||||
(values
|
||||
(append
|
||||
(take l (sub1 n))
|
||||
(list (list-ref l n)
|
||||
(list-ref l (sub1 n)))
|
||||
(drop l (add1 n)))
|
||||
(sub1 n)))))]))
|
||||
|
||||
(define lower-button (new button%
|
||||
[parent button-panel]
|
||||
[label (string-constant ml-cp-lower)]
|
||||
[callback (lambda (b e)
|
||||
(adjust-catalogs
|
||||
(lambda (l n)
|
||||
(values
|
||||
(append
|
||||
(take l n)
|
||||
(list (list-ref l (add1 n))
|
||||
(list-ref l n))
|
||||
(drop l (+ n 2)))
|
||||
(add1 n)))))]))
|
||||
|
||||
(send (new button% [parent button-panel] [label "1"]) show #f)
|
||||
|
||||
(define add-button (new button%
|
||||
[parent button-panel]
|
||||
[label (string-constant ml-cp-add)]
|
||||
[callback (lambda (b e)
|
||||
(define s (get-text-from-user
|
||||
(string-constant install-pkg-add-package-catalog)
|
||||
(string-constant install-plt-url)
|
||||
(get-top-level-window)
|
||||
#:validate (lambda (s)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn) #f)])
|
||||
(define u (string->url s))
|
||||
(and (url-scheme u)
|
||||
(or (eq? (url-scheme u) 'file)
|
||||
(url-host u)))))
|
||||
"http://..."
|
||||
'(disallow-invalid)))
|
||||
(when s
|
||||
(adjust-catalogs
|
||||
(lambda (l n)
|
||||
(values (append l (list s))
|
||||
(length l))))))]))
|
||||
|
||||
(define remove-button (new button%
|
||||
[parent button-panel]
|
||||
[label (string-constant ml-cp-remove)]
|
||||
[callback (lambda (b e)
|
||||
(adjust-catalogs
|
||||
(lambda (l n)
|
||||
(values
|
||||
(append
|
||||
(take l n)
|
||||
(drop l (add1 n)))
|
||||
#f))))]))
|
||||
|
||||
(define/private (catch-errors thunk)
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
(message-box
|
||||
(string-constant error)
|
||||
(exn-message exn)
|
||||
(get-top-level-window)
|
||||
'(ok stop)))])
|
||||
(thunk)))
|
||||
|
||||
(define/private (adjust-catalogs cb)
|
||||
(define l (for/list ([i (send catalog-list get-number)])
|
||||
(send catalog-list get-string i)))
|
||||
(define-values (new-l new-n) (cb l (send catalog-list get-selection)))
|
||||
(unless (equal? l new-l)
|
||||
(catch-errors
|
||||
(lambda ()
|
||||
(parameterize ([current-pkg-scope 'user])
|
||||
(with-pkg-lock
|
||||
(pkg-config #t (cons "catalogs" new-l))))
|
||||
(send catalog-list set new-l)
|
||||
(when new-n
|
||||
(send catalog-list set-selection new-n)))))
|
||||
(adjust-buttons))
|
||||
|
||||
(define/private (adjust-buttons)
|
||||
(define s (send catalog-list get-selection))
|
||||
(send remove-button enable s)
|
||||
(send raise-button enable (and s (positive? s)))
|
||||
(send lower-button enable (and s (s . < . (sub1 (send catalog-list get-number))))))
|
||||
|
||||
(define/private (adjust-all)
|
||||
(send catalog-list set (pkg-config-catalogs))
|
||||
(let ([scope (default-pkg-scope)])
|
||||
(send scope-choice set-selection (if (eq? scope 'user) 1 0))
|
||||
(send scope-choice enable (symbol? scope)))
|
||||
(adjust-buttons))
|
||||
|
||||
(define/override (on-superwindow-show on?)
|
||||
(when on?
|
||||
(adjust-all)))
|
||||
|
||||
(adjust-all)))
|
||||
|
|
@ -23,7 +23,8 @@ to the @exec{raco pkg} sub-subcommands.
|
|||
|
||||
Each-long form option of the command-line interface is a keyword
|
||||
argument to the functions described below. An argument corresponding to @DFlag{type}, @DFlag{deps},
|
||||
@DFlag{format}, or @DFlag{scope} accepts its argument as a symbol.
|
||||
@DFlag{format}, or @DFlag{scope} accepts its argument as a symbol, while
|
||||
other flags that take arguments expect strings.
|
||||
An argument corresponding to @DFlag{scope} is also allowed to be a path string,
|
||||
as would be provided to @DFlag{scope-dir}.
|
||||
Options without argument correspond to keyword arguments that
|
||||
|
|
|
|||
|
|
@ -1513,6 +1513,7 @@ please adhere to these guidelines:
|
|||
(ml-cp-collection-paths "Collection Paths")
|
||||
|
||||
;; button labels
|
||||
;; The package manager uses these, too
|
||||
(ml-cp-add "Add")
|
||||
(ml-cp-add-default "Add Default")
|
||||
(ml-cp-remove "Remove")
|
||||
|
|
@ -1786,19 +1787,24 @@ please adhere to these guidelines:
|
|||
(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-menu-item... "Install Package...")
|
||||
(install-pkg-dialog-title "Install Package")
|
||||
(install-pkg-source-label "Package Source")
|
||||
(install-pkg-type-label "Package Source Type")
|
||||
(install-pkg-package-name "Package Name")
|
||||
(install-pkg-infer "Infer")
|
||||
(install-pkg-use "Use") ; as opposed to "Infer", label for text box
|
||||
(install-pkg-type-label "Package Source Type")
|
||||
(install-pkg-file "File")
|
||||
(install-pkg-dir "Directory")
|
||||
(install-pkg-dir-url "URL Directory")
|
||||
(install-pkg-file-url "URL File")
|
||||
(install-pkg-dir-url "Remote Directory")
|
||||
(install-pkg-file-url "Remote File")
|
||||
(install-pkg-github "Github")
|
||||
(install-pkg-name "Name (consulting resolver)")
|
||||
(install-pkg-inferred-as "Type inferred to be ~a") ; ~a gets install-pkg-{file,dir,...}
|
||||
(install-pkg-force? "Overwrite Existing?")
|
||||
(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-command-line "Equivalent command line invocation:")
|
||||
(install-pkg-error-installing-title "Error Installing Package")
|
||||
(install-pkg-action-label "Action to Take")
|
||||
|
|
@ -1810,9 +1816,9 @@ please adhere to these guidelines:
|
|||
(install-pkg-action-inferred-to-be-install "Action inferred to be Install")
|
||||
(install-pkg-default "Default")
|
||||
(install-pkg-scope-label "Package Scope")
|
||||
(install-pkg-default-scope-label "Deafult Package Scope") ; for picking the scope to be default
|
||||
(install-pkg-installation "Specific Racket Installation")
|
||||
(install-pkg-user "Specific User and Racket Version")
|
||||
(install-pkg-shared "Specific User and All Racket Versions")
|
||||
(install-pkg-set-as-default "Set as Default")
|
||||
(install-pkg-scope-is "Package scope is ~a") ; ~a gets install-pkg-{installation,user,shared}
|
||||
(install-pkg-select-package-directory "Select Package Directory")
|
||||
|
|
@ -1826,9 +1832,13 @@ please adhere to these guidelines:
|
|||
(install-pkg-update-catalogs "Update")
|
||||
(install-pkg-do-not-update-catalogs "Don't Update")
|
||||
(install-pkg-really-remove? "Are you sure you want to remove the following selected packages?")
|
||||
(install-pkg-promote "Promote from Auto-Installed")
|
||||
(install-pkg-demote "Demote to Auto-Installed")
|
||||
(install-pkg-abort-install "Abort Install")
|
||||
(install-pkg-abort-update "Abort Update")
|
||||
(install-pkg-abort-remove "Abort Remove")
|
||||
(install-pkg-abort-demote "Abort Demote")
|
||||
(install-pkg-abort-promote "Abort Promote")
|
||||
(install-pkg-abort-migrate "Abort Migrate")
|
||||
(install-pkg-abort-generic-action "Abort Action")
|
||||
(install-pkg-show-all-options "Show All Options")
|
||||
|
|
@ -1840,16 +1850,20 @@ please adhere to these guidelines:
|
|||
|
||||
(install-pkg-abort-set-scope "Abort Scope Change")
|
||||
|
||||
(install-pkg-dependencies-fail "Fail: cancels the installation if dependencies unmet")
|
||||
(install-pkg-dependencies-force "Force: install despite missing dependencies")
|
||||
(install-pkg-dependencies-search-ask
|
||||
"Ask: prompt about each missing dependency (not supported in GUI)")
|
||||
(install-pkg-dependencies-search-auto "Auto: install missing dependencies automatically")
|
||||
(install-pkg-dependencies-fail "Fail: cancels installation/update if dependencies are unmet")
|
||||
(install-pkg-dependencies-force "Force: install despite missing or version-mismatched dependencies")
|
||||
(install-pkg-dependencies-search-ask "Ask: prompt about each missing dependency (not supported in GUI)")
|
||||
(install-pkg-dependencies-search-auto "Auto: install missing or version-mismatched dependencies automatically")
|
||||
(install-pkg-dependencies-search-auto+update "Auto + Update: update dependencies whenever possible")
|
||||
|
||||
(install-pkg-dependencies-mode "Dependencies Mode")
|
||||
|
||||
(install-pkg-dependencies-search-ask-not-supported-in-gui
|
||||
"The “ask“ mode for dependencies is not supported in the GUI installer.")
|
||||
(install-pkg-deps-is "Default deps mode is “~a”")
|
||||
;; "~a" is pre-":" part of `install-pkg-dependencies-fail' or `install-pkg-dependencies-search-auto':
|
||||
(install-pkg-deps-is "Default dependency mode is ~a")
|
||||
|
||||
(install-pkg-package-catalogs "Package Catalogs") ; label for a list box
|
||||
(install-pkg-add-package-catalog "Add Package Catalog")
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1669,12 +1669,12 @@
|
|||
(install-pkg-infer "Inferieren")
|
||||
(install-pkg-file "Datei")
|
||||
(install-pkg-dir "Verzeichnis")
|
||||
(install-pkg-dir-url "URL Verzeichnis")
|
||||
(install-pkg-file-url "URL Datei")
|
||||
; change: "URL" -> "Remote" (install-pkg-dir-url "URL Verzeichnis")
|
||||
; change: "URL" -> "Remote" (install-pkg-file-url "URL Datei")
|
||||
(install-pkg-github "Github")
|
||||
(install-pkg-name "Name (frage Auflöser)")
|
||||
(install-pkg-inferred-as "Typ inferiert als ~a") ; ~a gets install-pkg-{file,dir,...}
|
||||
(install-pkg-force? "Existierendes überschreiben?")
|
||||
; change: "force" is not "overwrite", not a question (install-pkg-force? "Existierendes überschreiben?")
|
||||
(install-pkg-command-line "Äquivalenter Kommandozeilen-Aufruf:")
|
||||
(install-pkg-error-installing-title "Fehler beim Installieren von Paket")
|
||||
|
||||
|
|
@ -1689,7 +1689,6 @@
|
|||
(install-pkg-scope-label "Paket-Einzugsbereich")
|
||||
(install-pkg-installation "Bestimmte Racket-Installation")
|
||||
(install-pkg-user "Bestimmter Benutzer und Racket-Version")
|
||||
(install-pkg-shared "Bestimmter Benutzer und alle Racket-Versionem")
|
||||
(install-pkg-set-as-default "Als Standard setzen")
|
||||
(install-pkg-scope-is "Paket-Einzugsbereich ist ~a") ; ~a gets install-pkg-{installation,user,shared}
|
||||
(install-pkg-select-package-directory "Paket-Verzeichnis auswählen")
|
||||
|
|
@ -1717,17 +1716,16 @@
|
|||
|
||||
(install-pkg-abort-set-scope "Änderung des Einzugsbereich widerrufen")
|
||||
|
||||
(install-pkg-dependencies-fail "Fehlschlag: widerruft die Installation falls Abhänigkeiten fehlen")
|
||||
; change: "installation" -> "installation/update" (install-pkg-dependencies-fail "Fehlschlag: widerruft die Installation falls Abhänigkeiten fehlen")
|
||||
(install-pkg-dependencies-force "Trotzdem: installieren trotz fehlender abhängigkeiten")
|
||||
(install-pkg-dependencies-search-ask
|
||||
"Fragen: bei jeder fehlenden Abhänigkeit fragen (nicht unterstützt in GUI)")
|
||||
(install-pkg-dependencies-search-ask "Fragen: bei jeder fehlenden Abhänigkeit fragen (nicht unterstützt in GUI)")
|
||||
(install-pkg-dependencies-search-auto "Auto: fehlende Abhänigkeiten automatisch installieren")
|
||||
|
||||
(install-pkg-dependencies-mode "Modus Abhängigkeiten")
|
||||
|
||||
(install-pkg-dependencies-search-ask-not-supported-in-gui
|
||||
"Der “Fragen“-Modus für Abhänigkeiten ist im GUI-Installierer nicht unterstützt.")
|
||||
(install-pkg-deps-is "Standard-Modus für Abhängigkeiten ist “~a”")
|
||||
(install-pkg-deps-is "Standard-Modus für Abhängigkeiten ist ~a")
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user