pkg/gui: first cut at a GUI package manager
For now, run it with `racket -l pkg/gui/main'. The expectation is that DrRacket will start using this GUI.
This commit is contained in:
Matthew Flatt
parent
8e7ec75ef8
commit
8c7632c025
|
|
@ -556,7 +556,11 @@ plt-extras :+= (package: "slatex")
|
|||
|
||||
;; -------------------- planet
|
||||
mz-extras :+= (package: "planet")
|
||||
mz-extras :+= (package: "pkg")
|
||||
|
||||
;; -------------------- pkg
|
||||
mz-extras :+= (- (package: "pkg")
|
||||
(collects: "pkg/gui/"))
|
||||
dr-extras :+= (collects: "pkg/gui/")
|
||||
|
||||
;; -------------------- mrlib
|
||||
mr-extras :+= (+ (- (package: "mrlib/")
|
||||
|
|
|
|||
|
|
@ -859,6 +859,8 @@ path/s is either such a string or a list of them.
|
|||
"collects/parser-tools/private-lex/error-tests.rkt" drdr:command-line #f
|
||||
"collects/picturing-programs" responsible (sbloch)
|
||||
"collects/pkg" responsible (jay)
|
||||
"collects/pkg/gui" responsible (mflatt)
|
||||
"collects/pkg/gui/main.rkt" drdr:command-line (mzc *)
|
||||
"collects/plai" responsible (jay)
|
||||
"collects/planet" responsible (robby)
|
||||
"collects/plot" responsible (ntoronto)
|
||||
|
|
|
|||
168
collects/pkg/gui/by-installed.rkt
Normal file
168
collects/pkg/gui/by-installed.rkt
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui/base
|
||||
racket/format
|
||||
pkg/lib
|
||||
(prefix-in pkg: pkg)
|
||||
string-constants
|
||||
"common.rkt")
|
||||
|
||||
(provide by-installed-panel%)
|
||||
|
||||
(struct ipkg (name scope auto? checksum source))
|
||||
|
||||
(define (scope<? a b)
|
||||
(case a
|
||||
[(installation) #t]
|
||||
[(user) (eq? b 'shared)]
|
||||
[else #f]))
|
||||
|
||||
(define (ipkg<? a b)
|
||||
(if (string=? (ipkg-name a) (ipkg-name b))
|
||||
(scope<? (ipkg-scope a) (ipkg-scope b))
|
||||
(string<? (ipkg-name a) (ipkg-name b))))
|
||||
|
||||
(define by-installed-panel%
|
||||
(class vertical-panel%
|
||||
(init-field [in-terminal in-terminal])
|
||||
|
||||
(super-new)
|
||||
|
||||
(inherit get-top-level-window)
|
||||
|
||||
(define pkg-list
|
||||
(new list-box%
|
||||
[parent this]
|
||||
[label #f]
|
||||
[choices null]
|
||||
[columns (list "Auto?/Scope" "Name" "Checksum" "Source")]
|
||||
[style '(multiple column-headers clickable-headers)]
|
||||
[callback (lambda (lb e)
|
||||
(when (e . is-a? . column-control-event%)
|
||||
(define sb (send e get-column))
|
||||
(if (= sb sort-by)
|
||||
(set! flip? (not flip?))
|
||||
(begin
|
||||
(set! sort-by sb)
|
||||
(set! flip? #f)))
|
||||
(sort-list!))
|
||||
(adjust-buttons!))]))
|
||||
|
||||
(define sort-by 0)
|
||||
(define flip? #f)
|
||||
(define installed '())
|
||||
(define sorted-installed '#())
|
||||
|
||||
(define/override (on-superwindow-show on?)
|
||||
(when on?
|
||||
(reset-installed-list!)))
|
||||
|
||||
(define/private (reset-installed-list!)
|
||||
(set! installed
|
||||
(for*/list ([scope (in-list '(installation user shared))]
|
||||
[(k v) (in-hash (installed-pkg-table #:scope scope))])
|
||||
(ipkg k scope (pkg-info-auto? v) (pkg-info-checksum v) (pkg-info-orig-pkg v))))
|
||||
(sort-list!))
|
||||
|
||||
(define/private (selected-ipkgs)
|
||||
(for/list ([i (in-list (send pkg-list get-selections))])
|
||||
(vector-ref sorted-installed i)))
|
||||
|
||||
(define button-line
|
||||
(new horizontal-panel%
|
||||
[parent this]
|
||||
[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
|
||||
#: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
|
||||
(string-constant install-pkg-abort-update)
|
||||
(lambda ()
|
||||
(apply
|
||||
pkg:update
|
||||
#:scope scope
|
||||
names)))
|
||||
(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)])
|
||||
(eq? (ipkg-scope i) (ipkg-scope (car ipkgs))))))
|
||||
(send remove-button enable same-scope?)
|
||||
(send update-button enable (and same-scope?
|
||||
(for/and ([i (in-list ipkgs)])
|
||||
(not (eq? 'link (car (ipkg-source i))))))))
|
||||
|
||||
(define/private (sort-list!)
|
||||
(define l (sort installed
|
||||
(lambda (a b)
|
||||
((if flip? not values)
|
||||
(case sort-by
|
||||
[(0) (if (eq? (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))
|
||||
(ipkg<? a b)
|
||||
(cond
|
||||
[(not (ipkg-checksum a)) #f]
|
||||
[(not (ipkg-checksum b)) #t]
|
||||
[else (string<? (ipkg-checksum a) (ipkg-checksum b))]))]
|
||||
[(3)
|
||||
(define sa (ipkg-source a))
|
||||
(define sb (ipkg-source b))
|
||||
(if (equal? sa sb)
|
||||
(ipkg<? a b)
|
||||
(if (eq? (car sa) (car sb))
|
||||
(string<? (cadr sa) (cadr sb))
|
||||
(case (car sa)
|
||||
[(link) #t]
|
||||
[(catalog) (eq? b 'url)]
|
||||
[(url) #f])))])))))
|
||||
(set! sorted-installed (list->vector l))
|
||||
(send pkg-list set
|
||||
(for/list ([i (in-list l)])
|
||||
(~a (if (ipkg-auto? i) "*" "")
|
||||
(ipkg-scope i)))
|
||||
(for/list ([i (in-list l)])
|
||||
(format "~a" (ipkg-name i)))
|
||||
(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"])
|
||||
(cadr s))))
|
||||
(adjust-buttons!))))
|
||||
497
collects/pkg/gui/by-list.rkt
Normal file
497
collects/pkg/gui/by-list.rkt
Normal file
|
|
@ -0,0 +1,497 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui/base
|
||||
racket/port
|
||||
racket/set
|
||||
racket/format
|
||||
string-constants
|
||||
net/url
|
||||
pkg/lib
|
||||
(prefix-in pkg: pkg)
|
||||
(prefix-in db: pkg/db)
|
||||
"common.rkt")
|
||||
|
||||
(provide by-list-panel%)
|
||||
|
||||
(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 "✓")
|
||||
|
||||
(define default-status
|
||||
(~a check-mark ": installed"
|
||||
" "
|
||||
"*: auto-installed"
|
||||
" "
|
||||
"!: not default scope"
|
||||
" "
|
||||
"=: installed as link"
|
||||
" "
|
||||
"@: installed from URL"))
|
||||
|
||||
(define by-list-panel%
|
||||
(class vertical-panel%
|
||||
(init-field [in-terminal in-terminal])
|
||||
|
||||
(super-new)
|
||||
|
||||
(inherit get-top-level-window)
|
||||
|
||||
(define tool-panel
|
||||
(new horizontal-panel%
|
||||
[parent this]
|
||||
[alignment '(left center)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(define keep-rx #rx"")
|
||||
(define/private (list-pkg-keep? a)
|
||||
(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))
|
||||
(regexp-match? keep-rx (format-tags (pkg-tags a)))
|
||||
(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 updating? #f)
|
||||
|
||||
(define update-button
|
||||
(new button%
|
||||
[label sc-pkg-update-package-list]
|
||||
[parent tool-panel]
|
||||
[font small-control-font]
|
||||
[callback
|
||||
(lambda (b e)
|
||||
(if updating?
|
||||
(interrupt-task!)
|
||||
(update-db-package-list)))]))
|
||||
|
||||
(define status-text
|
||||
(new message%
|
||||
[parent this]
|
||||
[label default-status]
|
||||
[font small-control-font]
|
||||
[stretchable-width #t]))
|
||||
|
||||
(define sort-column -1)
|
||||
(define list-pkg<? (lambda (a b) #f))
|
||||
|
||||
(define/private (sort-by! col)
|
||||
(define sel (case col
|
||||
[(0 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 switch (if (= sort-column col)
|
||||
not
|
||||
values))
|
||||
(set! sort-column (if (= sort-column col)
|
||||
-1
|
||||
col))
|
||||
(set! list-pkg<?
|
||||
(lambda (a b)
|
||||
(switch
|
||||
(cond
|
||||
[(and (not (string=? (sel a) ""))
|
||||
(string=? (sel b) ""))
|
||||
#t]
|
||||
[(and (string=? (sel a) "")
|
||||
(not (string=? (sel b) "")))
|
||||
#f]
|
||||
[(string<? (sel a) (sel b)) #t]
|
||||
[(string=? (sel a) (sel b))
|
||||
(cond
|
||||
[(string<? (db:pkg-name a) (db:pkg-name b)) #t]
|
||||
[(string=? (db:pkg-name a) (db:pkg-name b))
|
||||
(string<? (db:pkg-catalog a) (db:pkg-catalog))]
|
||||
[else #f])]
|
||||
[else #f])))))
|
||||
(sort-by! 7)
|
||||
|
||||
(define pkg-list
|
||||
(new list-box%
|
||||
[parent this]
|
||||
[label #f]
|
||||
[choices null]
|
||||
[columns (list check-mark "Package" "Author" "Description" "Tags" "Checksum" "Source" "Catalog")]
|
||||
[style '(multiple column-headers clickable-headers)]
|
||||
[callback (lambda (lb e)
|
||||
(when (e . is-a? . column-control-event%)
|
||||
(sort-by! (send e get-column))
|
||||
(sort-pkg-list!))
|
||||
(adjust-buttons!))]))
|
||||
|
||||
(send pkg-list set-column-width 0 30 2 1000)
|
||||
(send pkg-list set-column-width 3 300 2 1000)
|
||||
|
||||
(define button-line
|
||||
(new horizontal-panel%
|
||||
[parent this]
|
||||
[alignment '(center center)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(define install-button
|
||||
(new button%
|
||||
[label (string-constant install-pkg-install)]
|
||||
[parent button-line]
|
||||
[style '(border)]
|
||||
[callback (lambda (b e)
|
||||
(define pkgs (selected-pkgs))
|
||||
(define names (map db:pkg-name pkgs))
|
||||
(define first-inst
|
||||
(hash-ref installed (db:pkg-name (car pkgs)) #f))
|
||||
(define s (queue-scroll!))
|
||||
(in-terminal
|
||||
(if first-inst
|
||||
(string-constant install-pkg-abort-update)
|
||||
(string-constant install-pkg-abort-install))
|
||||
(lambda ()
|
||||
(apply
|
||||
(if first-inst pkg:update pkg:install)
|
||||
#:scope (and first-inst
|
||||
(car first-inst))
|
||||
names)))
|
||||
(set-box! s #f)
|
||||
(refresh-installed-list!))]))
|
||||
(define remove-button
|
||||
(new button%
|
||||
[label sc-install-pkg-remove]
|
||||
[parent button-line]
|
||||
[callback (lambda (b e)
|
||||
(define pkgs (selected-pkgs))
|
||||
(define names (map db:pkg-name pkgs))
|
||||
(when (really-remove? names #:parent (get-top-level-window))
|
||||
(define scope
|
||||
(car (hash-ref installed (db:pkg-name (car pkgs)) #f)))
|
||||
(define s (queue-scroll!))
|
||||
(in-terminal
|
||||
(string-constant install-pkg-abort-remove)
|
||||
(lambda ()
|
||||
(apply
|
||||
pkg:remove
|
||||
#:scope scope
|
||||
names)))
|
||||
(set-box! s #f)
|
||||
(refresh-installed-list!)))]))
|
||||
|
||||
;; When a terminal panel appears, it may shrink the
|
||||
;; list box enough that the selected item is not visible,
|
||||
;; so re-sort to adjust scrolling:
|
||||
(define (queue-scroll!)
|
||||
(define b (box #t))
|
||||
(queue-callback (lambda ()
|
||||
(when (unbox b)
|
||||
(sort-pkg-list!)))
|
||||
#f)
|
||||
b)
|
||||
|
||||
(define/private (selected-pkgs)
|
||||
(for/list ([i (in-list (send pkg-list get-selections))])
|
||||
(send pkg-list get-data i)))
|
||||
|
||||
(define/private (adjust-buttons!)
|
||||
(define sels (for/list ([p (selected-pkgs)])
|
||||
(hash-ref installed (db:pkg-name p) #f)))
|
||||
(define all-installed? (and (pair? sels)
|
||||
(andmap values sels)
|
||||
;; must be all in the same scope:
|
||||
(for/and ([p (cdr sels)])
|
||||
(eq? (car p) (caar sels)))))
|
||||
(define none-installed? (not (ormap values sels)))
|
||||
(send install-button enable (and (pair? sels)
|
||||
(or (and all-installed?
|
||||
(not (for/or ([p (in-list sels)])
|
||||
(eq? 'link (car (pkg-info-orig-pkg (cdr p)))))))
|
||||
none-installed?)))
|
||||
(send install-button set-label (if all-installed?
|
||||
(string-constant install-pkg-update)
|
||||
(string-constant install-pkg-install)))
|
||||
(send remove-button enable all-installed?))
|
||||
|
||||
(adjust-buttons!)
|
||||
|
||||
(define/private (check-catalogs)
|
||||
(define user-catalogs (pkg-config-catalogs))
|
||||
(define db-catalogs (db:get-catalogs))
|
||||
(unless (equal? (list->set db-catalogs)
|
||||
(list->set user-catalogs))
|
||||
(when (= 1 (message-box/custom "Package Catalogs"
|
||||
(~a
|
||||
(string-constant install-pkg-update-catalogs?)
|
||||
"\n\n"
|
||||
(string-constant install-pkg-currently-configured-are) ":\n"
|
||||
(apply ~a
|
||||
(for/list ([url user-catalogs])
|
||||
(~a " " url "\n")))
|
||||
"\n"
|
||||
(string-constant install-pkg-database-recorded-are) ":\n"
|
||||
(apply ~a
|
||||
(for/list ([url db-catalogs])
|
||||
(~a " " url "\n"))))
|
||||
(string-constant install-pkg-update-catalogs)
|
||||
(string-constant install-pkg-do-not-update-catalogs)
|
||||
#f
|
||||
this
|
||||
'(caution default=1)))
|
||||
(db:set-catalogs! user-catalogs)
|
||||
(update-db-package-list))))
|
||||
|
||||
(define/private (check-init)
|
||||
(unless (file-exists? (db:current-pkg-catalog-file))
|
||||
(db:set-catalogs! (pkg-config-catalogs))
|
||||
(update-db-package-list)))
|
||||
|
||||
(define task #f)
|
||||
(define finalize void)
|
||||
|
||||
(define/private (task! thunk given-finalize)
|
||||
(define finalized? #f)
|
||||
(set! finalize (lambda (ok?)
|
||||
(unless finalized?
|
||||
(set! finalized? #t)
|
||||
(given-finalize ok?))))
|
||||
(set! task (thread
|
||||
(lambda ()
|
||||
(with-handlers ([exn:break? void])
|
||||
(thunk)
|
||||
(let ([f finalize])
|
||||
(queue-callback/wait (lambda () (f #t)))))))))
|
||||
|
||||
(define/private (queue-callback/wait thunk)
|
||||
(define s (make-semaphore))
|
||||
(define ok? #t)
|
||||
(queue-callback (lambda ()
|
||||
(when ok?
|
||||
(thunk)
|
||||
(semaphore-post s))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (semaphore-wait s))
|
||||
(lambda () (set! ok? #f))))
|
||||
|
||||
(define/private (interrupt-task!)
|
||||
(when task
|
||||
(break-thread task)
|
||||
(sync task)
|
||||
(finalize #f))
|
||||
(set! task #f)
|
||||
(send status-text set-label default-status))
|
||||
|
||||
(define/private (update-db-package-list)
|
||||
(interrupt-task!)
|
||||
(set! updating? #t)
|
||||
(send update-button set-label sc-pkg-stop-update)
|
||||
(send status-text set-label "Updating package list...")
|
||||
(task!
|
||||
(lambda ()
|
||||
(define db-catalogs (db:get-catalogs))
|
||||
(for ([catalog (in-list db-catalogs)])
|
||||
(queue-callback/wait
|
||||
(lambda ()
|
||||
(send status-text set-label (format "Updating from ~a..." catalog))))
|
||||
(define details
|
||||
(parameterize ([current-pkg-catalogs (list (string->url catalog))])
|
||||
(get-all-pkg-details-from-catalogs)))
|
||||
(db:set-pkgs! catalog (for/list ([(name ht) (in-hash details)])
|
||||
(db:pkg name
|
||||
catalog
|
||||
(hash-ref ht 'author "")
|
||||
(hash-ref ht 'source "")
|
||||
(hash-ref ht 'checksum "")
|
||||
(hash-ref ht 'description ""))))
|
||||
(for/list ([(name ht) (in-hash details)])
|
||||
(db:set-pkg-tags! name catalog (hash-ref ht 'tags '())))))
|
||||
(lambda (finished?)
|
||||
(send status-text set-label default-status)
|
||||
(set! updating? #f)
|
||||
(send update-button set-label sc-pkg-update-package-list)
|
||||
(refresh-pkg-list!))))
|
||||
|
||||
(define/private (background-pkg-details)
|
||||
(task!
|
||||
(lambda ()
|
||||
(define catalog-ht (make-hash))
|
||||
(for ([a-pkg (in-vector pkgs)]
|
||||
[pos (in-naturals)])
|
||||
(define name (db:pkg-name a-pkg))
|
||||
(define catalog (db:pkg-catalog a-pkg))
|
||||
(send status-text set-label
|
||||
(~a "Getting details for " name " from " catalog "..."))
|
||||
(define all-ht
|
||||
(or (hash-ref catalog-ht catalog #f)
|
||||
(let ([all-ht (parameterize ([current-pkg-catalogs (list (string->url catalog))])
|
||||
(get-all-pkg-details-from-catalogs))])
|
||||
(hash-set! catalog-ht catalog all-ht)
|
||||
all-ht)))
|
||||
(define ht (hash-ref all-ht name))
|
||||
(define author (hash-ref ht 'author ""))
|
||||
(define source (hash-ref ht 'source ""))
|
||||
(define checksum (hash-ref ht 'checksum ""))
|
||||
(define desc (hash-ref ht 'description ""))
|
||||
(define tags (hash-ref ht 'tags '()))
|
||||
(define new-pkg (db:pkg name catalog author source checksum desc))
|
||||
(unless (and (equal? new-pkg a-pkg)
|
||||
(equal? tagss (pkg-tags a-pkg)))
|
||||
(db:set-pkg! name catalog author source checksum desc)
|
||||
(db:set-pkg-tags! name catalog tags)
|
||||
(queue-callback/wait
|
||||
(lambda ()
|
||||
(vector-set! pkgs pos new-pkg)
|
||||
(set! tagss (hash-set (hash-remove tagss a-pkg)
|
||||
new-pkg
|
||||
tags))
|
||||
(define lpos (vector-ref posns pos))
|
||||
(when lpos
|
||||
(send pkg-list set-string lpos (->label-string author) 2)
|
||||
(send pkg-list set-string lpos (->label-string desc) 3)
|
||||
(send pkg-list set-string lpos (->label-string (format-tags tags)) 4)
|
||||
(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))))
|
||||
|
||||
(define/private (->label-string s)
|
||||
(substring s 0 (min 200 (string-length s))))
|
||||
|
||||
(define pkgs '#())
|
||||
(define tagss #(hash))
|
||||
(define posns '#())
|
||||
(define installed '#())
|
||||
(define default-scope 'user)
|
||||
|
||||
(define/private (refresh-pkg-list!)
|
||||
(define pkg-list (db:get-pkgs))
|
||||
(define tags-list (map (lambda (p)
|
||||
(db:get-pkg-tags (db:pkg-name p)
|
||||
(db:pkg-catalog p)))
|
||||
pkg-list))
|
||||
(set! pkgs (list->vector pkg-list))
|
||||
(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-installed
|
||||
(for*/hash ([scope (in-list '(installation user shared))]
|
||||
[(k v) (in-hash (installed-pkg-table #:scope scope))])
|
||||
(values k (cons scope v))))
|
||||
(when (or always?
|
||||
(not (equal? installed new-installed)))
|
||||
(set! installed new-installed)
|
||||
(sort-pkg-list!)))
|
||||
|
||||
(define/private (pkg-tags p)
|
||||
(hash-ref tagss p '()))
|
||||
|
||||
(define/private (sort-pkg-list!)
|
||||
(define sels (for/list ([i (in-list (send pkg-list get-selections))])
|
||||
(define p (send pkg-list get-data i))
|
||||
(cons (db:pkg-name p) (db:pkg-catalog p))))
|
||||
(set! posns (make-vector (vector-length pkgs) #f))
|
||||
(define list-pkg+poses
|
||||
(sort
|
||||
(filter
|
||||
(lambda (p) (list-pkg-keep? (car p)))
|
||||
(for/list ([p pkgs]
|
||||
[i (in-naturals)])
|
||||
(cons p i)))
|
||||
list-pkg<?
|
||||
#:key car))
|
||||
(for ([p (in-list list-pkg+poses)]
|
||||
[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 pkg-list set
|
||||
(for/list ([p list-pkgs])
|
||||
(define v (hash-ref installed (db:pkg-name p) #f))
|
||||
(cond
|
||||
[(not v) ""]
|
||||
[else
|
||||
(define info (cdr v))
|
||||
(~a (cond
|
||||
[(pkg-info-auto? info) "*"]
|
||||
[else check-mark])
|
||||
(cond
|
||||
[(eq? (car v) default-scope) ""]
|
||||
[else "!"])
|
||||
(case (car (pkg-info-orig-pkg info))
|
||||
[(catalog) ""]
|
||||
[(link) "="]
|
||||
[(url) "@"]))]))
|
||||
(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)))
|
||||
(for/list ([p list-pkgs]) (->label-string (format-tags (pkg-tags p))))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-checksum p)))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-source p)))
|
||||
(for/list ([p list-pkgs]) (->label-string (db:pkg-catalog p))))
|
||||
(let ([ht (for/hash ([p list-pkgs]
|
||||
[i (in-naturals)])
|
||||
(send pkg-list set-data i p)
|
||||
(values (cons (db:pkg-name p) (db:pkg-catalog p))
|
||||
i))])
|
||||
(for/fold ([did? #f]) ([sel (in-list sels)])
|
||||
(define i (hash-ref ht sel #f))
|
||||
(when i
|
||||
(if did?
|
||||
(send pkg-list select i)
|
||||
(begin
|
||||
(send pkg-list set-selection i)
|
||||
(let ([f (send pkg-list get-first-visible-item)]
|
||||
[n (send pkg-list number-of-visible-items)])
|
||||
(unless (<= f i (+ f n -1))
|
||||
(send pkg-list set-first-visible-item
|
||||
(if (i . < . f)
|
||||
i
|
||||
(max 0 (add1 (- i n))))))))))
|
||||
(or did? i)))
|
||||
(adjust-buttons!))
|
||||
|
||||
(define/private (format-tags tags)
|
||||
(apply ~a #:separator ", " tags))
|
||||
|
||||
(define prepared? #f)
|
||||
|
||||
(define/override (on-superwindow-show on?)
|
||||
(if on?
|
||||
(cond
|
||||
[prepared? (refresh-installed-list!)]
|
||||
[else
|
||||
(check-init)
|
||||
(refresh-pkg-list!)
|
||||
(check-catalogs)
|
||||
(set! prepared? #t)])
|
||||
(interrupt-task!)))))
|
||||
395
collects/pkg/gui/by-source.rkt
Normal file
395
collects/pkg/gui/by-source.rkt
Normal file
|
|
@ -0,0 +1,395 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
racket/format
|
||||
string-constants
|
||||
pkg/name
|
||||
pkg/lib
|
||||
pkg
|
||||
racket/list
|
||||
framework
|
||||
net/url)
|
||||
|
||||
(provide by-source-panel%)
|
||||
|
||||
(define sc-install-pkg-dialog-title (string-constant install-pkg-dialog-title))
|
||||
(define sc-install-pkg-source-label (string-constant install-pkg-source-label))
|
||||
(define sc-install-pkg-type-label (string-constant install-pkg-type-label))
|
||||
(define sc-install-pkg-infer (string-constant install-pkg-infer))
|
||||
(define sc-install-pkg-file (string-constant install-pkg-file))
|
||||
(define sc-install-pkg-dir (string-constant install-pkg-dir))
|
||||
(define sc-install-pkg-dir-url (string-constant install-pkg-dir-url))
|
||||
(define sc-install-pkg-file-url (string-constant install-pkg-file-url))
|
||||
(define sc-install-pkg-github (string-constant install-pkg-github))
|
||||
(define sc-install-pkg-name (string-constant install-pkg-name))
|
||||
(define sc-install-pkg-inferred-as (string-constant install-pkg-inferred-as))
|
||||
(define sc-install-pkg-force? (string-constant install-pkg-force?))
|
||||
(define sc-install-pkg-command-line (string-constant install-pkg-command-line))
|
||||
|
||||
(define sc-install-pkg-action-label (string-constant install-pkg-action-label))
|
||||
(define sc-install-pkg-install (string-constant install-pkg-install))
|
||||
(define sc-install-pkg-update (string-constant install-pkg-update))
|
||||
(define sc-action-inferred-to-be-update (string-constant install-pkg-action-inferred-to-be-update))
|
||||
(define sc-action-inferred-to-be-install (string-constant install-pkg-action-inferred-to-be-install))
|
||||
|
||||
(define sc-install-pkg-default (string-constant install-pkg-default))
|
||||
(define sc-install-pkg-scope-label (string-constant install-pkg-scope-label))
|
||||
(define sc-install-pkg-installation (string-constant install-pkg-installation))
|
||||
(define sc-install-pkg-user (string-constant install-pkg-user))
|
||||
(define sc-install-pkg-shared (string-constant install-pkg-shared))
|
||||
(define sc-install-pkg-set-as-default (string-constant install-pkg-set-as-default))
|
||||
(define sc-install-pkg-scope-is (string-constant install-pkg-scope-is))
|
||||
|
||||
(define sc-install-pkg-browse (string-constant browse...))
|
||||
|
||||
(preferences:set-default 'drracket:gui-installer-pkg-source "" string?)
|
||||
|
||||
(define by-source-panel%
|
||||
(class vertical-panel%
|
||||
(init-field [in-terminal in-terminal])
|
||||
|
||||
(super-new)
|
||||
|
||||
(inherit get-top-level-window)
|
||||
|
||||
(define source-panel (new horizontal-panel%
|
||||
[parent this]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(define tf (new text-field%
|
||||
[parent source-panel]
|
||||
[min-width 600]
|
||||
[label (~a sc-install-pkg-source-label ":")]
|
||||
[callback (λ (_1 _2)
|
||||
(preferences:set 'drracket:gui-installer-pkg-source (send tf get-value))
|
||||
(adjust-all))]))
|
||||
(send tf set-value (preferences:get 'drracket:gui-installer-pkg-source))
|
||||
|
||||
(define browse-button (new button%
|
||||
[parent source-panel]
|
||||
[label (string-constant browse...)]
|
||||
[font small-control-font]
|
||||
[callback (lambda (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)))]))
|
||||
|
||||
(define button-panel (new horizontal-panel%
|
||||
[parent this]
|
||||
[stretchable-height #f]))
|
||||
(define details-parent (new vertical-panel% [parent this]))
|
||||
(define details-panel (new group-box-panel%
|
||||
[label (string-constant autosave-details)]
|
||||
[parent details-parent]
|
||||
[alignment '(left center)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(define ok-button
|
||||
(new button%
|
||||
[label sc-install-pkg-install]
|
||||
[parent button-panel]
|
||||
[style '(border)]
|
||||
[callback (lambda (b e)
|
||||
(define res (compute-cmd-line))
|
||||
(in-terminal
|
||||
(case (car res)
|
||||
[(install) (string-constant install-pkg-abort-install)]
|
||||
[(update) (string-constant install-pkg-abort-update)])
|
||||
(lambda ()
|
||||
(define action (case (car res)
|
||||
[(install) install]
|
||||
[(update) update]))
|
||||
(apply action (cdr res))))
|
||||
(reset-installed-pkgs!))]))
|
||||
|
||||
(define/private (reset-installed-pkgs!)
|
||||
(set! currently-installed-pkgs (installed-pkg-names))
|
||||
(adjust-all))
|
||||
|
||||
(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 choice (new choice%
|
||||
[label (~a sc-install-pkg-type-label ":")]
|
||||
[parent details-panel]
|
||||
[stretchable-width #t]
|
||||
[callback (λ (x y) (adjust-all))]
|
||||
[choices (list sc-install-pkg-infer
|
||||
sc-install-pkg-file
|
||||
sc-install-pkg-dir
|
||||
sc-install-pkg-file-url
|
||||
sc-install-pkg-dir-url
|
||||
sc-install-pkg-github
|
||||
sc-install-pkg-name)]))
|
||||
|
||||
(define inferred-msg-parent (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
[stretchable-height #f]
|
||||
[alignment '(right center)]))
|
||||
(define inferred-msg (new message% [label ""] [parent inferred-msg-parent] [auto-resize #t]))
|
||||
|
||||
(define action-choice (new choice%
|
||||
[label (~a sc-install-pkg-action-label ":")]
|
||||
[parent details-panel]
|
||||
[stretchable-width #t]
|
||||
[callback (λ (x y) (adjust-all))]
|
||||
[choices (list sc-install-pkg-infer
|
||||
sc-install-pkg-install
|
||||
sc-install-pkg-update)]))
|
||||
(define inferred-action-msg-parent (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
[stretchable-height #f]
|
||||
[alignment '(right center)]))
|
||||
(define inferred-action-msg (new message% [label ""] [parent inferred-action-msg-parent] [auto-resize #t]))
|
||||
|
||||
|
||||
(define scope-panel (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
[stretchable-height #f]))
|
||||
(define scope-choice (new choice%
|
||||
[label (~a sc-install-pkg-scope-label ":")]
|
||||
[parent scope-panel]
|
||||
[stretchable-width #t]
|
||||
[callback (λ (x y) (adjust-all))]
|
||||
[choices (list sc-install-pkg-default
|
||||
sc-install-pkg-installation
|
||||
sc-install-pkg-user
|
||||
sc-install-pkg-shared)]))
|
||||
(define/private (selected-scope) (case (send scope-choice get-selection)
|
||||
[(0) (default-pkg-scope)]
|
||||
[(1) 'installation]
|
||||
[(2) 'user]
|
||||
[(3) 'shared]))
|
||||
(define scope-default-button (new button%
|
||||
[label sc-install-pkg-set-as-default]
|
||||
[font small-control-font]
|
||||
[parent scope-panel]
|
||||
[callback (lambda (b e)
|
||||
(in-terminal
|
||||
(lambda ()
|
||||
(define scope (selected-scope))
|
||||
(config #:scope 'installation #:set #t "default-scope" (~a scope))
|
||||
(printf "Default scope successfully changed to ~a" scope)))
|
||||
(adjust-all))]))
|
||||
(define inferred-scope-msg-parent (new horizontal-panel%
|
||||
[parent details-panel]
|
||||
[stretchable-height #f]
|
||||
[alignment '(right center)]))
|
||||
(define scope-msg (new message% [label ""] [parent inferred-scope-msg-parent] [auto-resize #t]))
|
||||
|
||||
(define cb (new check-box%
|
||||
[label sc-install-pkg-force?]
|
||||
[parent details-panel]
|
||||
[callback (λ (a b) (adjust-all))]))
|
||||
|
||||
(new message% [parent details-panel] [label " "]) ; a spacer
|
||||
|
||||
(new message% [parent details-panel] [label sc-install-pkg-command-line])
|
||||
(define cmdline-panel (new horizontal-panel% [parent details-panel] [stretchable-height #f]))
|
||||
(new horizontal-panel% [parent cmdline-panel] [min-width 12] [stretchable-width #f])
|
||||
(define cmdline-msg (new message%
|
||||
[parent cmdline-panel]
|
||||
[stretchable-width #t]
|
||||
[label ""]
|
||||
[font (send (send (editor:get-standard-style-list)
|
||||
find-named-style
|
||||
"Standard")
|
||||
get-font)]))
|
||||
|
||||
(define/private (selected-type)
|
||||
(case (send choice get-selection)
|
||||
[(0) #f]
|
||||
[(1) 'file]
|
||||
[(2) 'dir]
|
||||
[(3) 'file-url]
|
||||
[(4) 'dir-url]
|
||||
[(5) 'github]
|
||||
[(6) 'name]))
|
||||
|
||||
(define/private (type->str type)
|
||||
(case type
|
||||
[(file) sc-install-pkg-file]
|
||||
[(name) sc-install-pkg-name]
|
||||
[(dir) sc-install-pkg-dir]
|
||||
[(github) sc-install-pkg-github]
|
||||
[(file-url) sc-install-pkg-file-url]
|
||||
[(dir-url) sc-install-pkg-dir-url]
|
||||
[else (error 'type->str "unknown type ~s\n" type)]))
|
||||
|
||||
(define currently-installed-pkgs (installed-pkg-names))
|
||||
(define/private (get-current-action)
|
||||
(case (send action-choice get-selection)
|
||||
[(0)
|
||||
(define current-name (package-source->name (send tf get-value)))
|
||||
(cond
|
||||
[(and current-name (member current-name currently-installed-pkgs))
|
||||
'update]
|
||||
[else
|
||||
'install])]
|
||||
[(1) 'install]
|
||||
[(2) 'update]))
|
||||
|
||||
|
||||
(define/private (adjust-all)
|
||||
(adjust-inferred)
|
||||
(adjust-inferred-action)
|
||||
(adjust-checkbox)
|
||||
(adjust-cmd-line)
|
||||
(adjust-details-shown)
|
||||
(adjust-browse)
|
||||
(adjust-scope)
|
||||
(adjust-ok))
|
||||
|
||||
(define/private (adjust-checkbox)
|
||||
(send cb enable (equal? 'install (get-current-action))))
|
||||
|
||||
(define/private (adjust-inferred-action)
|
||||
(define action (get-current-action))
|
||||
(define new-lab
|
||||
(cond
|
||||
[(equal? 0 (send action-choice get-selection))
|
||||
(case (get-current-action)
|
||||
[(install) sc-action-inferred-to-be-install]
|
||||
[(update) sc-action-inferred-to-be-update])]
|
||||
[else ""]))
|
||||
(send inferred-action-msg set-label new-lab))
|
||||
|
||||
(define/private (adjust-ok)
|
||||
(send ok-button set-label (case (get-current-action)
|
||||
[(install) sc-install-pkg-install]
|
||||
[(update) sc-install-pkg-update]))
|
||||
(send ok-button enable (compute-cmd-line)))
|
||||
|
||||
(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 shown? (member browse-button (send source-panel get-children)))
|
||||
(unless (eq? (and show? #t) (and shown? #t))
|
||||
(if show?
|
||||
(send source-panel add-child browse-button)
|
||||
(send source-panel delete-child browse-button))))
|
||||
|
||||
(define/private (adjust-details-shown)
|
||||
(define current-details-shown-state?
|
||||
(and (member details-panel (send details-parent get-children))
|
||||
#t))
|
||||
(unless (equal? current-details-shown-state?
|
||||
details-shown?)
|
||||
(cond
|
||||
[details-shown?
|
||||
(send details-button set-label (string-constant hide-details-button-label))
|
||||
(send details-parent change-children
|
||||
(λ (l) (list details-panel)))]
|
||||
[else
|
||||
(send details-button set-label (string-constant show-details-button-label))
|
||||
(send details-parent change-children
|
||||
(λ (l) '()))])))
|
||||
|
||||
(define/private (adjust-inferred)
|
||||
(define new-lab
|
||||
(and (equal? #f (selected-type))
|
||||
(let-values ([(_ actual-type)
|
||||
(package-source->name+type (send tf get-value) #f)])
|
||||
(and actual-type
|
||||
(format sc-install-pkg-inferred-as (type->str actual-type))))))
|
||||
(send inferred-msg set-label (or new-lab "")))
|
||||
|
||||
(define/private (adjust-scope)
|
||||
(send scope-msg set-label (format sc-install-pkg-scope-is
|
||||
(case (selected-scope)
|
||||
[(installation) sc-install-pkg-installation]
|
||||
[(user) sc-install-pkg-user]
|
||||
[(shared) sc-install-pkg-shared])))
|
||||
(define is-default? (let ([v (send scope-choice get-selection)])
|
||||
(or (zero? v)
|
||||
(= v (case (default-pkg-scope)
|
||||
[(installation) 1]
|
||||
[(user) 2]
|
||||
[(shared) 3])))))
|
||||
(define deleted? (not (member scope-default-button (send scope-panel get-children))))
|
||||
(unless (equal? is-default? deleted?)
|
||||
(if is-default?
|
||||
(send scope-panel delete-child scope-default-button)
|
||||
(send scope-panel add-child scope-default-button))))
|
||||
|
||||
(define/private (adjust-cmd-line)
|
||||
(define (convert-to-string s)
|
||||
(cond
|
||||
[(string? s)
|
||||
(if (regexp-match #rx" " s)
|
||||
(string-append "\"" s "\"")
|
||||
s)]
|
||||
[(keyword? s) (regexp-replace #rx"^#:" (format "~a" s) "--")]
|
||||
[(symbol? s) (symbol->string s)]
|
||||
[(boolean? s) #f]
|
||||
[else (error 'convert-to-string "unk ~s" s)]))
|
||||
(define cmd-line (compute-cmd-line))
|
||||
(send cmdline-msg set-label
|
||||
(if cmd-line
|
||||
(string-append
|
||||
(if (eq? (system-type) 'windows)
|
||||
"raco.exe"
|
||||
"raco")
|
||||
" pkg "
|
||||
(apply string-append
|
||||
(add-between
|
||||
(filter values (map convert-to-string cmd-line))
|
||||
" ")))
|
||||
"")))
|
||||
|
||||
(define/private (compute-cmd-line)
|
||||
(define the-pkg
|
||||
(cond
|
||||
[(and (equal? 'update (get-current-action))
|
||||
(package-source->name (send tf get-value)))
|
||||
=>
|
||||
values]
|
||||
[else (send tf get-value)]))
|
||||
(and (not (equal? the-pkg ""))
|
||||
(cons (get-current-action)
|
||||
(append
|
||||
(if (send cb get-value)
|
||||
'(#:force #t)
|
||||
'())
|
||||
(if (selected-type)
|
||||
(list '#:type (selected-type))
|
||||
'())
|
||||
(let ([scope (selected-scope)])
|
||||
(if (equal? scope (default-pkg-scope))
|
||||
'()
|
||||
(list '#:scope scope)))
|
||||
(list the-pkg)))))
|
||||
|
||||
(define/override (on-superwindow-show on?)
|
||||
(when on?
|
||||
(reset-installed-pkgs!)))
|
||||
|
||||
(adjust-all)))
|
||||
25
collects/pkg/gui/common.rkt
Normal file
25
collects/pkg/gui/common.rkt
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui/base
|
||||
string-constants
|
||||
racket/format)
|
||||
|
||||
(provide really-remove?
|
||||
sc-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-remove? #:parent [parent #f] names)
|
||||
(equal? 1
|
||||
(message-box/custom sc-install-pkg-remove
|
||||
(apply ~a
|
||||
really-uninstall?-msg
|
||||
(for/list ([n (in-list names)])
|
||||
(~a "\n " n)))
|
||||
sc-install-pkg-remove
|
||||
(string-constant cancel)
|
||||
#f
|
||||
parent
|
||||
'(caution default=1))))
|
||||
|
||||
58
collects/pkg/gui/main.rkt
Normal file
58
collects/pkg/gui/main.rkt
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui/base
|
||||
framework
|
||||
"by-source.rkt"
|
||||
"by-list.rkt"
|
||||
"by-installed.rkt"
|
||||
mrlib/terminal
|
||||
string-constants)
|
||||
|
||||
(define frame
|
||||
(new frame:basic%
|
||||
[label "Package Manager"]
|
||||
[width 800]
|
||||
[height 600]))
|
||||
|
||||
(define sel-tab
|
||||
(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))]
|
||||
[callback (lambda (t e)
|
||||
(define old (send sel-panel active-child))
|
||||
(define new (list-ref panels (send t get-selection)))
|
||||
(unless (eq? new old)
|
||||
(send sel-panel active-child new)))]))
|
||||
|
||||
(define sel-panel
|
||||
(new panel:single%
|
||||
[parent sel-tab]))
|
||||
|
||||
(define terminal #f)
|
||||
(define (in-terminal-panel abort-label thunk)
|
||||
(when terminal
|
||||
(send terminal close))
|
||||
(define t (in-terminal
|
||||
#:abort-label abort-label
|
||||
#:container (send frame get-area-container)
|
||||
(λ (cust parent) (thunk))))
|
||||
(set! terminal t)
|
||||
(send sel-tab enable #f)
|
||||
(yield (send t can-close-evt))
|
||||
(send sel-tab enable #t))
|
||||
|
||||
(define panels
|
||||
(list
|
||||
(new by-source-panel%
|
||||
[parent sel-panel]
|
||||
[in-terminal in-terminal-panel])
|
||||
(new by-list-panel%
|
||||
[parent sel-panel]
|
||||
[in-terminal in-terminal-panel])
|
||||
(new by-installed-panel%
|
||||
[parent sel-panel]
|
||||
[in-terminal in-terminal-panel])))
|
||||
|
||||
(send frame show #t)
|
||||
|
|
@ -1773,6 +1773,9 @@ 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-menu-item... "Install Package...")
|
||||
(install-pkg-dialog-title "Install Package")
|
||||
(install-pkg-source-label "Package Source")
|
||||
|
|
@ -1786,10 +1789,35 @@ please adhere to these guidelines:
|
|||
(install-pkg-name "Name (consulting resolver)")
|
||||
(install-pkg-inferred-as "Type inferred to be ~a")
|
||||
(install-pkg-force? "Overwrite Existing?")
|
||||
(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-action-label "Action to Take")
|
||||
(install-pkg-install "Install")
|
||||
(install-pkg-update "Update")
|
||||
(install-pkg-action-inferred-to-be-update "Action Inferred to be Update")
|
||||
(install-pkg-action-inferred-to-be-install "Action Inferred to be Install"))
|
||||
(install-pkg-remove "Remove")
|
||||
(install-pkg-action-inferred-to-be-update "Action inferred to be Update")
|
||||
(install-pkg-action-inferred-to-be-install "Action inferred to be Install")
|
||||
(install-pkg-default "Default")
|
||||
(install-pkg-scope-label "Package Scope")
|
||||
(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")
|
||||
(install-pkg-select-package-file "Select Package File")
|
||||
(install-pkg-update-package-list "Update Package List")
|
||||
(install-pkg-stop-update "Stop Update")
|
||||
(install-pkg-filter "Filter")
|
||||
(install-pkg-update-catalogs? "Update database to match the configured set of catalogs?")
|
||||
(install-pkg-currently-configured-are "The currently configured catalogs are")
|
||||
(install-pkg-database-recorded-are "The database-recorded catalogs are")
|
||||
(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-abort-install "Abort Install")
|
||||
(install-pkg-abort-update "Abort Update")
|
||||
(install-pkg-abort-remove "Abort Remove")
|
||||
(install-pkg-abort-generic-action "Abort Action")
|
||||
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user