switch DrRacket's "Install Package..." to the new package manager GUI
This commit is contained in:
Matthew Flatt
parent
e468d1f6a5
commit
05c0299be4
|
|
@ -1,262 +1,16 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(module install-pkg racket/base
|
(module install-pkg racket/base
|
||||||
(require racket/gui/base
|
(require racket/class
|
||||||
racket/class
|
pkg/gui/main)
|
||||||
string-constants
|
|
||||||
pkg/name
|
|
||||||
pkg/lib
|
|
||||||
racket/list
|
|
||||||
framework)
|
|
||||||
(provide install-pkg)
|
(provide install-pkg)
|
||||||
|
|
||||||
(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))
|
|
||||||
|
|
||||||
(preferences:set-default 'drracket:gui-installer-pkg-source "" string?)
|
|
||||||
|
|
||||||
(define (install-pkg parent)
|
|
||||||
(define dlg (new dialog%
|
|
||||||
[parent parent]
|
|
||||||
[label sc-install-pkg-dialog-title]
|
|
||||||
[alignment '(right center)]))
|
|
||||||
(define tf (new text-field%
|
|
||||||
[parent dlg]
|
|
||||||
[min-width 600]
|
|
||||||
[label 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 details-parent (new vertical-panel% [parent dlg]))
|
|
||||||
(define details-panel (new group-box-panel%
|
|
||||||
[label (string-constant autosave-details)]
|
|
||||||
[parent details-parent]
|
|
||||||
[alignment '(left center)]))
|
|
||||||
(define button-panel (new horizontal-panel%
|
|
||||||
[parent dlg]
|
|
||||||
[stretchable-height #f]
|
|
||||||
[alignment '(right center)]))
|
|
||||||
|
|
||||||
|
|
||||||
(define details-shown? #f)
|
(define pkg-gui #f)
|
||||||
(define details-button (new button%
|
|
||||||
[label (string-constant show-details-button-label)]
|
(define (install-pkg parent wrap-terminal-action)
|
||||||
[parent button-panel]
|
(if pkg-gui
|
||||||
[callback
|
(send pkg-gui show #t)
|
||||||
(λ (a b)
|
(set! pkg-gui (make-pkg-gui #:wrap-terminal-action wrap-terminal-action)))))
|
||||||
(set! details-shown? (not details-shown?))
|
|
||||||
(adjust-all))]))
|
|
||||||
(new horizontal-panel% [parent button-panel])
|
|
||||||
(define-values (ok-button cancel-button)
|
|
||||||
(gui-utils:ok/cancel-buttons button-panel
|
|
||||||
(λ (_1 _2)
|
|
||||||
(set! ok? #t)
|
|
||||||
(send dlg show #f))
|
|
||||||
(λ (_1 _2) (send dlg show #f))))
|
|
||||||
(send details-parent change-children (λ (l) '()))
|
|
||||||
(define choice (new choice%
|
|
||||||
[label 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 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 cb (new check-box%
|
|
||||||
[label sc-install-pkg-force?]
|
|
||||||
[parent details-panel]
|
|
||||||
[callback (λ (a b) (adjust-all))]))
|
|
||||||
|
|
||||||
(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 (selected-type)
|
|
||||||
(case (send choice get-selection)
|
|
||||||
[(0) #f]
|
|
||||||
[(1) 'file]
|
|
||||||
[(2) 'dir]
|
|
||||||
[(3) 'file-url]
|
|
||||||
[(4) 'dir-url]
|
|
||||||
[(5) 'github]
|
|
||||||
[(6) 'name]))
|
|
||||||
|
|
||||||
(define (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 (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 (adjust-all)
|
|
||||||
(adjust-inferred)
|
|
||||||
(adjust-inferred-action)
|
|
||||||
(adjust-checkbox)
|
|
||||||
(adjust-cmd-line)
|
|
||||||
(adjust-details-shown)
|
|
||||||
(adjust-ok/cancel))
|
|
||||||
|
|
||||||
(define (adjust-checkbox)
|
|
||||||
(send cb enable (equal? 'install (get-current-action))))
|
|
||||||
|
|
||||||
(define (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 (adjust-ok/cancel)
|
|
||||||
(send ok-button enable (compute-cmd-line)))
|
|
||||||
|
|
||||||
(define (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 (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 (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 (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))
|
|
||||||
'())
|
|
||||||
(list the-pkg)))))
|
|
||||||
|
|
||||||
(adjust-all)
|
|
||||||
|
|
||||||
(define ok? #f)
|
|
||||||
|
|
||||||
(send dlg show #t)
|
|
||||||
(and ok? (compute-cmd-line))))
|
|
||||||
|
|
||||||
(module main racket
|
(module main racket
|
||||||
(require (submod ".." install-pkg))
|
(require (submod ".." install-pkg))
|
||||||
|
|
@ -450,17 +204,11 @@
|
||||||
[label (string-constant install-pkg-menu-item...)]
|
[label (string-constant install-pkg-menu-item...)]
|
||||||
[parent file-menu]
|
[parent file-menu]
|
||||||
[callback
|
[callback
|
||||||
(λ (item evt)
|
(λ (item evt)
|
||||||
(define res (install-pkg this))
|
(install-pkg this
|
||||||
(when res
|
(lambda (thunk)
|
||||||
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
|
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
|
||||||
(in-terminal
|
(thunk)))))])
|
||||||
#:title (string-constant install-pkg-dialog-title)
|
|
||||||
(λ (cust parent)
|
|
||||||
(define action (case (car res)
|
|
||||||
[(install) install]
|
|
||||||
[(update) update]))
|
|
||||||
(apply action (cdr res)))))))])
|
|
||||||
(super file-menu:between-open-and-revert file-menu))
|
(super file-menu:between-open-and-revert file-menu))
|
||||||
|
|
||||||
(define/override (file-menu:between-print-and-close menu)
|
(define/override (file-menu:between-print-and-close menu)
|
||||||
|
|
|
||||||
|
|
@ -8,51 +8,62 @@
|
||||||
mrlib/terminal
|
mrlib/terminal
|
||||||
string-constants)
|
string-constants)
|
||||||
|
|
||||||
(define frame
|
(provide make-pkg-gui)
|
||||||
(new frame:basic%
|
|
||||||
[label "Package Manager"]
|
|
||||||
[width 800]
|
|
||||||
[height 600]))
|
|
||||||
|
|
||||||
(define sel-tab
|
(define (make-pkg-gui #:wrap-terminal-action [wrap-terminal-action (lambda (thunk) (thunk))])
|
||||||
(new tab-panel%
|
(define frame
|
||||||
[parent (send frame get-area-container)]
|
(new (class frame:standard-menus%
|
||||||
[choices (list (string-constant install-pkg-install-by-source)
|
(super-new)
|
||||||
(string-constant install-pkg-install-from-list)
|
;; no menu separator:
|
||||||
(string-constant install-pkg-install-installed))]
|
(define/override (edit-menu:between-select-all-and-find m) (void)))
|
||||||
[callback (lambda (t e)
|
[label "Package Manager"]
|
||||||
(define old (send sel-panel active-child))
|
[width 800]
|
||||||
(define new (list-ref panels (send t get-selection)))
|
[height 600]))
|
||||||
(unless (eq? new old)
|
|
||||||
(send sel-panel active-child new)))]))
|
|
||||||
|
|
||||||
(define sel-panel
|
(define sel-tab
|
||||||
(new panel:single%
|
(new tab-panel%
|
||||||
[parent sel-tab]))
|
[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 terminal #f)
|
(define sel-panel
|
||||||
(define (in-terminal-panel abort-label thunk)
|
(new panel:single%
|
||||||
(when terminal
|
[parent sel-tab]))
|
||||||
(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
|
(define terminal #f)
|
||||||
(list
|
(define (in-terminal-panel abort-label thunk)
|
||||||
(new by-source-panel%
|
(when terminal
|
||||||
[parent sel-panel]
|
(send terminal close))
|
||||||
[in-terminal in-terminal-panel])
|
(define t (in-terminal
|
||||||
(new by-list-panel%
|
#:abort-label abort-label
|
||||||
[parent sel-panel]
|
#:container (send frame get-area-container)
|
||||||
[in-terminal in-terminal-panel])
|
(λ (cust parent) (wrap-terminal-action thunk))))
|
||||||
(new by-installed-panel%
|
(set! terminal t)
|
||||||
[parent sel-panel]
|
(send sel-tab enable #f)
|
||||||
[in-terminal in-terminal-panel])))
|
(yield (send t can-close-evt))
|
||||||
|
(send sel-tab enable #t))
|
||||||
|
|
||||||
(send frame show #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)
|
||||||
|
|
||||||
|
frame)
|
||||||
|
|
||||||
|
(module+ main
|
||||||
|
(void (make-pkg-gui)))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user