document gui-pkg-manager and add pkg-catalog-update-local/simple-status-dialog
This commit is contained in:
Robby Findler
parent
60e2c2400d
commit
ec0053be7f
5
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-doc/info.rkt
Normal file
5
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-doc/info.rkt
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
#lang info
|
||||
(define collection 'multi)
|
||||
(define deps '("base" "racket-doc" "scribble-lib"))
|
||||
(define pkg-desc "documentation part of \"gui-pkg-manager\"")
|
||||
(define pkg-authors '(mflatt robby))
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/bnf
|
||||
scribble/core
|
||||
(for-label pkg racket/base))
|
||||
|
||||
@title{Package Management GUI Libraries}
|
||||
|
||||
@author[@author+email["Matthew Flatt" "mflatt@racket-lang.org"]
|
||||
@author+email["Jay McCarthy" "jay@racket-lang.org"]
|
||||
@author+email["Robert Bruce Findler" "robby@racket-lang.org"]]
|
||||
|
||||
@declare-exporting[pkg/gui]
|
||||
|
||||
The @tt{gui-pkg-manager} provides GUI support for package management.
|
||||
|
||||
@defproc[(make-pkg-gui
|
||||
[#:wrap-terminal-action wrap-terminal-action (-> (-> any) any) (λ (t) (t))]
|
||||
[#:initial-tab initial-tab (or/c 'by-source 'installed 'from-list 'migrate) 'by-source])
|
||||
(is-a?/c top-level-window<%>)]{
|
||||
Opens the package manager GUI starting with the @racket[initial-tab] selected.
|
||||
|
||||
The @racket[wrap-terminal-action] function is passed a thunk that it is expected to
|
||||
invoke, possibly after redirecting the @racket[current-output-port] and @racket[current-error-port]
|
||||
to point to an existing GUI window.
|
||||
}
|
||||
|
||||
@defproc[(make-pkg-installer
|
||||
[#:parent parent (or/c #f (is-a?/c top-level-window<%>)) #f]
|
||||
[#:wrap-terminal-action wrap-terminal-action (-> (-> any) any) (λ (t) (t))]
|
||||
[#:package-to-offer package-to-offer (or/c #f string?) #f])
|
||||
(is-a?/c top-level-window<%>)]{
|
||||
|
||||
Opens a specialized version of the @racket[make-pkg-gui] window that contains only the
|
||||
@racket['by-source] panel.
|
||||
|
||||
The @racket[wrap-terminal-action] function is passed a thunk that it is expected to
|
||||
invoke, possibly after redirecting the @racket[current-output-port] and @racket[current-error-port]
|
||||
to point to an existing GUI window.
|
||||
}
|
||||
|
||||
@defproc[(pkg-catalog-update-local/simple-status-dialog
|
||||
[#:parent parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f])
|
||||
void?]{
|
||||
Calls @racket[pkg-catalog-update-local] with a simple @racket[dialog%]
|
||||
that shows which catalog servers are being consulted.
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang info
|
||||
|
||||
(define scribblings
|
||||
'(("gui/scribblings/gui-pkg-manager.scrbl")))
|
||||
|
|
@ -3,11 +3,12 @@
|
|||
racket/gui/base
|
||||
racket/contract/base
|
||||
framework
|
||||
"by-source.rkt"
|
||||
"by-list.rkt"
|
||||
"by-installed.rkt"
|
||||
"by-migrate.rkt"
|
||||
"settings.rkt"
|
||||
"gui/private/by-source.rkt"
|
||||
"gui/private/by-list.rkt"
|
||||
"gui/private/by-installed.rkt"
|
||||
"gui/private/by-migrate.rkt"
|
||||
"gui/private/settings.rkt"
|
||||
"gui/private/catalog-update.rkt"
|
||||
mrlib/terminal
|
||||
string-constants)
|
||||
|
||||
|
|
@ -28,7 +29,9 @@
|
|||
(-> (-> any) any)
|
||||
#:package-to-offer
|
||||
(or/c #f string?))
|
||||
(is-a?/c top-level-window<%>))]))
|
||||
(is-a?/c top-level-window<%>))]
|
||||
[pkg-catalog-update-local/simple-status-dialog
|
||||
(->* () (#:parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)) void?)]))
|
||||
|
||||
(define pkg-gui-frame%
|
||||
(class (frame:standard-menus-mixin
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
#lang racket/base
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
racket/contract
|
||||
string-constants
|
||||
pkg/lib
|
||||
(prefix-in db: pkg/db))
|
||||
(provide
|
||||
pkg-catalog-update-local/simple-status-dialog)
|
||||
|
||||
(define (pkg-catalog-update-local/simple-status-dialog #:parent [parent #f])
|
||||
(define error-message-shown? #f)
|
||||
(define d%
|
||||
(class dialog%
|
||||
(define/override (on-subwindow-event w e)
|
||||
(if (and error-message-shown? (send e button-down?))
|
||||
(if (is-a? w button%)
|
||||
#f
|
||||
(if (or (is-a? w message%)
|
||||
(and
|
||||
(is-a? w editor-canvas%)
|
||||
(let-values ([(w h) (send w get-client-size)])
|
||||
(< (send e get-x) w))))
|
||||
(begin
|
||||
(send w popup-menu
|
||||
(let ([m (make-object popup-menu%)])
|
||||
(make-object menu-item%
|
||||
"Copy Message"
|
||||
m
|
||||
(lambda (i e)
|
||||
(send the-clipboard
|
||||
set-clipboard-string
|
||||
(send err-msg-txt get-text 0 (send err-msg-txt last-position))
|
||||
(send e get-time-stamp))))
|
||||
m)
|
||||
(send e get-x)
|
||||
(send e get-y))
|
||||
#t)
|
||||
#f))
|
||||
#f))
|
||||
(super-new)))
|
||||
(define d (new d%
|
||||
[width 600]
|
||||
[parent parent]
|
||||
[label (string-constant update-catalog)]))
|
||||
(define m (new message%
|
||||
[parent d]
|
||||
[label ""]
|
||||
[stretchable-width #t]))
|
||||
|
||||
(define err-msg-txt (new text%))
|
||||
(define (show-exn exn)
|
||||
(set! error-message-shown? #t)
|
||||
(send d begin-container-sequence)
|
||||
(parameterize ([current-output-port (open-output-text-editor err-msg-txt)])
|
||||
(display (exn-message exn))
|
||||
(define context (continuation-mark-set->context
|
||||
(exn-continuation-marks exn)))
|
||||
(unless (null? context)
|
||||
(printf "\n")
|
||||
(for ([x (in-list context)])
|
||||
(printf "\n ~s" x))))
|
||||
(define sd (make-object style-delta% 'change-family 'modern))
|
||||
(send sd set-delta-foreground "darkred")
|
||||
(send err-msg-txt change-style sd 0 (send err-msg-txt last-position))
|
||||
(send err-msg-txt lock #t)
|
||||
(send err-msg-txt hide-caret #t)
|
||||
(define ec (new editor-canvas%
|
||||
[parent d]
|
||||
[min-height 400]
|
||||
[editor err-msg-txt]))
|
||||
(define bp (new horizontal-panel%
|
||||
[parent d]
|
||||
[stretchable-height #f]
|
||||
[alignment '(right center)]))
|
||||
(define b (new button%
|
||||
[label (string-constant ok)]
|
||||
[parent bp]
|
||||
[callback
|
||||
(λ (_1 _2) (send d show #f))]))
|
||||
(send d end-container-sequence))
|
||||
|
||||
(thread
|
||||
(λ ()
|
||||
(with-handlers ([exn:fail?
|
||||
(λ (exn)
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(show-exn exn))))])
|
||||
(for ([catalog (in-list (db:get-catalogs))])
|
||||
(define s (make-semaphore 0))
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(send m set-label (format (string-constant updating-catalog-from) catalog))
|
||||
(semaphore-post s)))
|
||||
(semaphore-wait s)
|
||||
(pkg-catalog-update-local #:catalogs (list catalog)
|
||||
#:set-catalogs? #f
|
||||
#:quiet? #t))
|
||||
(queue-callback
|
||||
(λ () (send d show #f))))))
|
||||
|
||||
(send d show #t))
|
||||
|
|
@ -3,10 +3,12 @@
|
|||
(define collection 'multi)
|
||||
|
||||
(define deps '("gui-pkg-manager-lib"
|
||||
"gui-pkg-manager-doc"
|
||||
"gui-lib"
|
||||
"base"))
|
||||
|
||||
(define implies '("gui-pkg-manager-lib"))
|
||||
(define implies '("gui-pkg-manager-lib"
|
||||
"gui-pkg-manager-doc"))
|
||||
|
||||
(define pkg-desc "Graphical tool for managing Racket package installations")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require pkg/gui/main)
|
||||
(require pkg/gui)
|
||||
|
||||
(void (make-pkg-gui))
|
||||
|
||||
|
|
@ -9,4 +9,3 @@
|
|||
(module+ test
|
||||
(require racket/gui/base)
|
||||
(queue-callback (lambda () (exit)) #f))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user