20e74c40bc
the package installer and make DrRacket have two separate menu items, one for installing a package (which now looks simpler again) and one for doing all of the things you can currently do with the package system in a GUI
159 lines
4.4 KiB
Racket
159 lines
4.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/gui/base
|
|
racket/contract/base
|
|
framework
|
|
"by-source.rkt"
|
|
"by-list.rkt"
|
|
"by-installed.rkt"
|
|
mrlib/terminal
|
|
string-constants)
|
|
|
|
(provide
|
|
(contract-out
|
|
[make-pkg-gui
|
|
(->* ()
|
|
(#:wrap-terminal-action
|
|
(-> (-> any) any)
|
|
#:initial-tab
|
|
(or/c 'by-source 'from-list 'installed))
|
|
(is-a?/c top-level-window<%>))]
|
|
[make-pkg-installer
|
|
(->* ()
|
|
(#:parent
|
|
(or/c #f (is-a?/c top-level-window<%>))
|
|
#:wrap-terminal-action
|
|
(-> (-> any) any))
|
|
(is-a?/c top-level-window<%>))]))
|
|
|
|
(define pkg-gui-frame%
|
|
(class (frame:standard-menus-mixin
|
|
(frame:status-line-mixin
|
|
frame:basic%))
|
|
(super-new)
|
|
;; no menu separator:
|
|
(define/override (edit-menu:between-select-all-and-find m) (void))))
|
|
|
|
(define (make-pkg-installer #:parent
|
|
[parent #f]
|
|
#:wrap-terminal-action
|
|
[wrap-terminal-action (λ (t) (t))])
|
|
|
|
(define allow-close? #t)
|
|
|
|
(define dlg
|
|
(new (class dialog%
|
|
(define/augment (can-close?)
|
|
allow-close?)
|
|
(super-new
|
|
[parent parent]
|
|
[label "Package Installer"]))))
|
|
|
|
(define terminal #f)
|
|
(define (in-terminal-panel abort-label thunk)
|
|
(send dlg begin-container-sequence)
|
|
(when terminal (send terminal close))
|
|
(define t (in-terminal
|
|
#:abort-label abort-label
|
|
#:canvas-min-height 400
|
|
#:container dlg
|
|
#:close-button? #f
|
|
(λ (cust parent) (wrap-terminal-action thunk))))
|
|
(send dlg reflow-container)
|
|
(unless terminal (send dlg center))
|
|
(set! terminal t)
|
|
(disallow-close)
|
|
(send dlg end-container-sequence)
|
|
(yield (send t can-close-evt))
|
|
(allow-close))
|
|
|
|
(define (disallow-close)
|
|
(set! allow-close? #f)
|
|
(send close enable #f))
|
|
|
|
(define (allow-close)
|
|
(set! allow-close? #t)
|
|
(send close enable #t))
|
|
|
|
(define by-source-panel
|
|
(new by-source-panel%
|
|
[parent dlg]
|
|
[in-terminal in-terminal-panel]))
|
|
|
|
(define close (new button%
|
|
[label (string-constant close)]
|
|
[parent (send by-source-panel get-button-panel)]
|
|
[callback
|
|
(λ (x y)
|
|
(send dlg show #f))]))
|
|
|
|
(send dlg show #t)
|
|
|
|
dlg)
|
|
|
|
(define (make-pkg-gui #:wrap-terminal-action
|
|
[wrap-terminal-action (lambda (thunk) (thunk))]
|
|
#:initial-tab [initial-tab 'installed])
|
|
|
|
(define frame
|
|
(new pkg-gui-frame%
|
|
[label "Package Manager"]
|
|
[width 800]
|
|
[height 600]))
|
|
|
|
(define (update-sel-panel-active)
|
|
(define old (send sel-panel active-child))
|
|
(define new (list-ref (send sel-panel get-children) (send sel-tab get-selection)))
|
|
(unless (eq? new old)
|
|
(send sel-panel active-child new)))
|
|
|
|
(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)
|
|
(update-sel-panel-active))]))
|
|
|
|
(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) (wrap-terminal-action thunk))))
|
|
(set! terminal t)
|
|
(send sel-tab enable #f)
|
|
(yield (send t can-close-evt))
|
|
(send sel-tab enable #t))
|
|
|
|
(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 sel-tab set-selection
|
|
(case initial-tab
|
|
[(by-source) 0]
|
|
[(from-list) 1]
|
|
[(installed) 2]))
|
|
(update-sel-panel-active)
|
|
|
|
(send frame show #t)
|
|
|
|
frame)
|
|
|
|
(module+ main
|
|
(void (make-pkg-installer)))
|