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
|
||||
|
||||
(module install-pkg racket/base
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
string-constants
|
||||
pkg/name
|
||||
pkg/lib
|
||||
racket/list
|
||||
framework)
|
||||
(require racket/class
|
||||
pkg/gui/main)
|
||||
(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 pkg-gui #f)
|
||||
|
||||
(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 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))]))
|
||||
(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))))
|
||||
(define (install-pkg parent wrap-terminal-action)
|
||||
(if pkg-gui
|
||||
(send pkg-gui show #t)
|
||||
(set! pkg-gui (make-pkg-gui #:wrap-terminal-action wrap-terminal-action)))))
|
||||
|
||||
(module main racket
|
||||
(require (submod ".." install-pkg))
|
||||
|
|
@ -451,16 +205,10 @@
|
|||
[parent file-menu]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
(define res (install-pkg this))
|
||||
(when res
|
||||
(install-pkg this
|
||||
(lambda (thunk)
|
||||
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
|
||||
(in-terminal
|
||||
#:title (string-constant install-pkg-dialog-title)
|
||||
(λ (cust parent)
|
||||
(define action (case (car res)
|
||||
[(install) install]
|
||||
[(update) update]))
|
||||
(apply action (cdr res)))))))])
|
||||
(thunk)))))])
|
||||
(super file-menu:between-open-and-revert file-menu))
|
||||
|
||||
(define/override (file-menu:between-print-and-close menu)
|
||||
|
|
|
|||
|
|
@ -8,8 +8,14 @@
|
|||
mrlib/terminal
|
||||
string-constants)
|
||||
|
||||
(provide make-pkg-gui)
|
||||
|
||||
(define (make-pkg-gui #:wrap-terminal-action [wrap-terminal-action (lambda (thunk) (thunk))])
|
||||
(define frame
|
||||
(new frame:basic%
|
||||
(new (class frame:standard-menus%
|
||||
(super-new)
|
||||
;; no menu separator:
|
||||
(define/override (edit-menu:between-select-all-and-find m) (void)))
|
||||
[label "Package Manager"]
|
||||
[width 800]
|
||||
[height 600]))
|
||||
|
|
@ -37,7 +43,7 @@
|
|||
(define t (in-terminal
|
||||
#:abort-label abort-label
|
||||
#:container (send frame get-area-container)
|
||||
(λ (cust parent) (thunk))))
|
||||
(λ (cust parent) (wrap-terminal-action thunk))))
|
||||
(set! terminal t)
|
||||
(send sel-tab enable #f)
|
||||
(yield (send t can-close-evt))
|
||||
|
|
@ -56,3 +62,8 @@
|
|||
[in-terminal in-terminal-panel])))
|
||||
|
||||
(send frame show #t)
|
||||
|
||||
frame)
|
||||
|
||||
(module+ main
|
||||
(void (make-pkg-gui)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user