suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix PR 13970 is a slightly less ugly way

Browse Source
This commit is contained in:
Robby Findler 2013-08-17 20:46:13 -05:00
parent ef13798cd5
commit 908b036347
1 changed files with 46 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-source.rkt
View File

@ -131,14 +131,17 @@
[callback (lambda (b e) [callback (lambda (b e)
(define res (compute-cmd-line)) (define res (compute-cmd-line))
(in-terminal (in-terminal
(case (car res) (case (cmdline-which res)
[(install) (string-constant install-pkg-abort-install)] [(install) (string-constant install-pkg-abort-install)]
[(update) (string-constant install-pkg-abort-update)]) [(update) (string-constant install-pkg-abort-update)])
(lambda () (lambda ()
(define action (case (car res) (define action (case (cmdline-which res)
[(install) pkg-install-command] [(install) pkg-install-command]
[(update) pkg-update-command])) [(update) pkg-update-command]))
(apply/keywords action (cdr res)))) (keyword-apply action
(cmdline-kwds res)
(cmdline-kwd-args res)
(cmdline-args res))))
(reset-installed-pkgs!))])) (reset-installed-pkgs!))]))
(define/private (reset-installed-pkgs!) (define/private (reset-installed-pkgs!)
@ -418,16 +421,10 @@
[(4) 'search-auto])) [(4) 'search-auto]))
(define/private (adjust-cmd-line) (define/private (adjust-cmd-line)
(define (convert-to-string s) (define (possibly-quote-string s)
(cond
[(string? s)
(if (regexp-match #rx" " s) (if (regexp-match #rx" " s)
(string-append "\"" s "\"") (string-append "\"" s "\"")
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)) (define cmd-line (compute-cmd-line))
(send cmdline-msg set-label (send cmdline-msg set-label
(if cmd-line (if cmd-line
@ -436,12 +433,23 @@
"raco.exe" "raco.exe"
"raco") "raco")
" pkg " " pkg "
(apply string-append (format "~a " (cmdline-which cmd-line))
(apply
string-append
(add-between (add-between
(filter values (map convert-to-string cmd-line)) (map (λ (kwd kwd-arg)
" "))) (format "--~a ~s"
(regexp-replace #rx"^#:" (format "~a" kwd) "")
kwd-arg))
(cmdline-kwds cmd-line)
(cmdline-kwd-args cmd-line))
" "))
(apply string-append
(map (λ (x) (format " ~a" (possibly-quote-string x)))
(cmdline-args cmd-line))))
""))) "")))
(struct cmdline (which kwds kwd-args args) #:transparent)
(define/private (compute-cmd-line) (define/private (compute-cmd-line)
(define the-pkg (define the-pkg
(cond (cond
@ -450,43 +458,26 @@
=> =>
values] values]
[else (send tf get-value)])) [else (send tf get-value)]))
(and (not (equal? the-pkg "")) (cond
(cons (get-current-action) [(equal? the-pkg "") #f]
(append [else
(if (and (send cb is-enabled?) (send cb get-value)) (define kwds '())
'(#:force #t) (define kwd-args '())
'()) (define (add-kwd-arg kwd arg)
(if (selected-type) (set! kwds (cons kwd kwds))
(list '#:type (selected-type)) (set! kwd-args (cons arg kwd-args)))
'()) (when (and (send cb is-enabled?) (send cb get-value))
(add-kwd-arg '#:force #t))
(when (selected-type)
(add-kwd-arg '#:type (selected-type)))
(let ([scope (selected-scope)]) (let ([scope (selected-scope)])
(if (equal? scope (default-pkg-scope)) (unless (equal? scope (default-pkg-scope))
'() (add-kwd-arg '#:scope scope)))
(list '#:scope scope))) (add-kwd-arg '#:deps (get-deps-selected-type))
(list '#:deps (get-deps-selected-type)) (cmdline (get-current-action) kwds kwd-args (list the-pkg))]))
(list the-pkg)))))
(define/override (on-superwindow-show on?) (define/override (on-superwindow-show on?)
(when on? (when on?
(reset-installed-pkgs!))) (reset-installed-pkgs!)))
;; Pull keyword arguments out of the list `all-args';
;; assumes that no keyword is intended as an argument value.
;; (This seems ugly.)
(define/private (apply/keywords proc all-args)
(define-values (args kws kw-vals)
(let loop ([args all-args] [rev-args null] [kws+vals null])
(cond
[(null? args)
(let ([kws+vals (sort kws+vals keyword<? #:key car)])
(values (reverse rev-args)
(map car kws+vals)
(map cdr kws+vals)))]
[(keyword? (car args))
(loop (cddr args) rev-args (cons (cons (car args) (cadr args))
kws+vals))]
[else
(loop (cdr args) (cons (car args) rev-args) kws+vals)])))
(keyword-apply proc kws kw-vals args))
(adjust-all))) (adjust-all)))