e34e63b323
drracket's "install package" menu item It will infer whether to use 'raco pkg update' or 'raco pkg install' based on the currently installed set of packages (but, of course, the details section of the dialog lets you override this inference if necessary)
1074 lines
46 KiB
Racket
1074 lines
46 KiB
Racket
#lang racket/base
|
|
|
|
(module install-pkg racket/base
|
|
(require racket/gui/base
|
|
racket/class
|
|
string-constants
|
|
pkg/name
|
|
pkg/lib
|
|
racket/list
|
|
framework)
|
|
(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 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))))
|
|
|
|
(module main racket
|
|
(require (submod ".." install-pkg))
|
|
(install-pkg #f))
|
|
|
|
(require string-constants
|
|
racket/match
|
|
racket/class
|
|
racket/string
|
|
racket/file
|
|
racket/math
|
|
racket/unit
|
|
"drsig.rkt"
|
|
racket/gui/base
|
|
framework
|
|
net/url
|
|
net/head
|
|
setup/plt-installer
|
|
help/bug-report
|
|
setup/unpack
|
|
mrlib/terminal
|
|
pkg
|
|
(submod "." install-pkg))
|
|
(provide frame@)
|
|
(define-unit frame@
|
|
(import [prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket:app: drracket:app^]
|
|
[prefix help: drracket:help-desk^]
|
|
[prefix drracket:multi-file-search: drracket:multi-file-search^]
|
|
[prefix drracket:init: drracket:init^]
|
|
[prefix drracket: drracket:interface^])
|
|
(export (rename drracket:frame^
|
|
[-mixin mixin]))
|
|
|
|
(define last-keybindings-planet-attempt "")
|
|
|
|
(define basics-mixin
|
|
(mixin (frame:standard-menus<%>) (drracket:frame:basics<%>)
|
|
|
|
(define/override (on-subwindow-focus win on?)
|
|
(when the-keybindings-frame
|
|
(when on?
|
|
(send the-keybindings-frame set-bindings
|
|
(if (can-show-keybindings?)
|
|
(get-keybindings-to-show)
|
|
'())))))
|
|
|
|
(define/override (on-subwindow-char receiver event)
|
|
(let ([user-key? (send (keymap:get-user)
|
|
handle-key-event
|
|
(if (is-a? receiver editor-canvas%)
|
|
(send receiver get-editor)
|
|
receiver)
|
|
event)])
|
|
;; (printf "user-key? ~s\n" user-key?) returns #t for key release events -- is this a problem? (we'll find out!)
|
|
(or user-key?
|
|
(super on-subwindow-char receiver event))))
|
|
|
|
(inherit get-edit-target-window get-edit-target-object get-menu-bar)
|
|
(define/private (get-menu-bindings)
|
|
(let ([name-ht (make-hasheq)])
|
|
(let loop ([menu-container (get-menu-bar)])
|
|
(for-each
|
|
(λ (item)
|
|
(when (is-a? item selectable-menu-item<%>)
|
|
(let ([short-cut (send item get-shortcut)])
|
|
(when short-cut
|
|
(let ([keyname
|
|
(string->symbol
|
|
(keymap:canonicalize-keybinding-string
|
|
(string-append
|
|
(menu-item->prefix-string item)
|
|
(case short-cut
|
|
[(#\;) "semicolon"]
|
|
[(#\:) "colon"]
|
|
[(#\space) "space"]
|
|
[else
|
|
(cond
|
|
[(symbol? short-cut) (symbol->string short-cut)]
|
|
[(char? short-cut) (string short-cut)])]))))])
|
|
(hash-set! name-ht keyname (send item get-plain-label))))))
|
|
(when (is-a? item menu-item-container<%>)
|
|
(loop item)))
|
|
(send menu-container get-items)))
|
|
(when (eq? (system-type) 'windows)
|
|
(for-each (λ (top-level-menu)
|
|
(when (is-a? top-level-menu menu%)
|
|
(let ([amp-key
|
|
(let loop ([str (send top-level-menu get-label)])
|
|
(cond
|
|
[(regexp-match #rx"[^&]*[&](.)(.*)" str)
|
|
=>
|
|
(λ (m)
|
|
(let ([this-amp (list-ref m 1)]
|
|
[rest (list-ref m 2)])
|
|
(cond
|
|
[(equal? this-amp "&")
|
|
(loop rest)]
|
|
[else
|
|
(string-downcase this-amp)])))]
|
|
[else #f]))])
|
|
(when amp-key
|
|
(hash-set! name-ht
|
|
(format "m:~a" amp-key)
|
|
(format "~a menu" (send top-level-menu get-plain-label)))
|
|
(hash-set! name-ht
|
|
(format "m:s:~a" amp-key)
|
|
(format "~a menu" (send top-level-menu get-plain-label)))))))
|
|
(send (get-menu-bar) get-items)))
|
|
name-ht))
|
|
|
|
(define/private (menu-item->prefix-string item)
|
|
(apply
|
|
string-append
|
|
(map (λ (prefix)
|
|
(case prefix
|
|
[(alt) (if (eq? (system-type) 'windows)
|
|
"m:"
|
|
"a:")]
|
|
[(cmd) "d:"]
|
|
[(meta) "m:"]
|
|
[(ctl) "c:"]
|
|
[(shift) "s:"]
|
|
[(opt option) "a:"]
|
|
[else (error 'menu-item->prefix-string "unknown prefix ~s\n" prefix)]))
|
|
(send item get-shortcut-prefix))))
|
|
|
|
(define/private (copy-hash-table ht)
|
|
(let ([res (make-hasheq)])
|
|
(hash-for-each
|
|
ht
|
|
(λ (x y) (hash-set! res x y)))
|
|
res))
|
|
|
|
(define/private (can-show-keybindings?)
|
|
(let ([edit-object (get-edit-target-object)])
|
|
(and edit-object
|
|
(is-a? edit-object editor<%>)
|
|
(let ([keymap (send edit-object get-keymap)])
|
|
(is-a? keymap keymap:aug-keymap<%>)))))
|
|
|
|
;; pre: (can-show-keybindings?) = #t
|
|
(define/private (get-keybindings-to-show)
|
|
(define edit-object (get-edit-target-object))
|
|
(define keymap (send edit-object get-keymap))
|
|
(define menu-names (get-menu-bindings))
|
|
(define table (send keymap get-map-function-table))
|
|
(define bindings (hash-map table list))
|
|
(define w/menus
|
|
(append (hash-map menu-names list)
|
|
(filter (λ (binding) (not (bound-by-menu? binding menu-names)))
|
|
bindings)))
|
|
(sort
|
|
w/menus
|
|
(λ (x y) (string-ci<=? (cadr x) (cadr y)))))
|
|
|
|
(define/private (show-keybindings)
|
|
(if (can-show-keybindings?)
|
|
(show-keybindings-to-user (get-keybindings-to-show) this)
|
|
(bell)))
|
|
|
|
(define/private (bound-by-menu? binding menu-table)
|
|
(ormap (λ (constituent)
|
|
(hash-ref menu-table (string->symbol constituent) (λ () #f)))
|
|
(regexp-split #rx";" (symbol->string (car binding)))))
|
|
|
|
(define/override (help-menu:before-about help-menu)
|
|
(make-help-desk-menu-item help-menu))
|
|
|
|
(define/override (help-menu:about-callback item evt) (drracket:app:about-drscheme))
|
|
(define/override (help-menu:about-string) (string-constant about-drscheme))
|
|
(define/override (help-menu:create-about?) #t)
|
|
|
|
(define/public (get-additional-important-urls) '())
|
|
(define/override (help-menu:after-about menu)
|
|
(drracket-help-menu:after-about menu this))
|
|
|
|
(define/override (file-menu:new-string) (string-constant new-menu-item))
|
|
(define/override (file-menu:open-string) (string-constant open-menu-item))
|
|
|
|
(define/override (file-menu:between-open-and-revert file-menu)
|
|
(new menu-item%
|
|
[label (string-constant install-plt-file-menu-item...)]
|
|
[parent file-menu]
|
|
[callback (λ (item evt)
|
|
(install-plt-file this))])
|
|
(new menu-item%
|
|
[label (string-constant install-pkg-menu-item...)]
|
|
[parent file-menu]
|
|
[callback
|
|
(λ (item evt)
|
|
(define res (install-pkg this))
|
|
(when res
|
|
(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)))))))])
|
|
(super file-menu:between-open-and-revert file-menu))
|
|
|
|
(define/override (file-menu:between-print-and-close menu)
|
|
(super file-menu:between-print-and-close menu)
|
|
(instantiate menu-item% ()
|
|
(label (string-constant mfs-multi-file-search-menu-item))
|
|
(parent menu)
|
|
(callback
|
|
(λ (_1 _2)
|
|
(drracket:multi-file-search:multi-file-search))))
|
|
(new separator-menu-item% (parent menu)))
|
|
|
|
(define/override (edit-menu:between-find-and-preferences menu)
|
|
(super edit-menu:between-find-and-preferences menu)
|
|
(when (current-eventspace-has-standard-menus?)
|
|
(new separator-menu-item% [parent menu]))
|
|
(let ([keybindings-on-demand
|
|
(λ (menu-item)
|
|
(let ([last-edit-object (get-edit-target-window)])
|
|
(send menu-item enable (can-show-keybindings?))))])
|
|
(instantiate menu% ()
|
|
(label (string-constant keybindings-menu-item))
|
|
(parent menu)
|
|
(demand-callback
|
|
(λ (keybindings-menu)
|
|
(for-each (λ (old) (send old delete))
|
|
(send keybindings-menu get-items))
|
|
(new menu-item%
|
|
(parent keybindings-menu)
|
|
(label (string-constant keybindings-show-active))
|
|
(callback (λ (x y) (show-keybindings)))
|
|
(help-string (string-constant keybindings-info))
|
|
(demand-callback keybindings-on-demand))
|
|
(new menu-item%
|
|
(parent keybindings-menu)
|
|
(label (string-constant keybindings-add-user-defined-keybindings))
|
|
(callback
|
|
(λ (x y)
|
|
(with-handlers ([exn? (λ (x)
|
|
(printf "~a\n" (exn-message x)))])
|
|
(let ([filename (finder:get-file
|
|
#f
|
|
(string-constant keybindings-choose-user-defined-file)
|
|
#f
|
|
""
|
|
this)])
|
|
(when filename
|
|
(add-keybindings-item/update-prefs filename)))))))
|
|
(new menu-item%
|
|
(parent keybindings-menu)
|
|
(label (string-constant keybindings-add-user-defined-keybindings/planet))
|
|
(callback
|
|
(λ (x y)
|
|
(let ([planet-spec (get-text-from-user (string-constant drscheme)
|
|
(string-constant keybindings-type-planet-spec)
|
|
this
|
|
last-keybindings-planet-attempt)])
|
|
(when planet-spec
|
|
(set! last-keybindings-planet-attempt planet-spec)
|
|
(cond
|
|
[(planet-string-spec? planet-spec)
|
|
=>
|
|
(λ (planet-sexp-spec)
|
|
(add-keybindings-item/update-prefs planet-sexp-spec))]
|
|
[else
|
|
(message-box (string-constant drscheme)
|
|
(format (string-constant keybindings-planet-malformed-spec)
|
|
planet-spec)
|
|
#:dialog-mixin frame:focus-table-mixin)]))))))
|
|
(let ([ud (preferences:get 'drracket:user-defined-keybindings)])
|
|
(unless (null? ud)
|
|
(new separator-menu-item% (parent keybindings-menu))
|
|
(for-each (λ (item)
|
|
(new menu-item%
|
|
(label (format (string-constant keybindings-menu-remove)
|
|
(if (path? item)
|
|
(path->string item)
|
|
(format "~s" item))))
|
|
(parent keybindings-menu)
|
|
(callback
|
|
(λ (x y) (remove-keybindings-item item)))))
|
|
ud)))))))
|
|
(unless (current-eventspace-has-standard-menus?)
|
|
(make-object separator-menu-item% menu)))
|
|
|
|
(super-new)))
|
|
|
|
(define (add-keybindings-item/update-prefs item)
|
|
(when (add-keybindings-item item)
|
|
(preferences:set 'drracket:user-defined-keybindings
|
|
(cons item
|
|
(preferences:get 'drracket:user-defined-keybindings)))))
|
|
|
|
(define (planet-string-spec? p)
|
|
(let ([sexp
|
|
(with-handlers ([exn:fail:read? (λ (x) #f)])
|
|
(read (open-input-string p)))])
|
|
(and sexp
|
|
(planet-spec? sexp)
|
|
sexp)))
|
|
|
|
(define (planet-spec? p)
|
|
(match p
|
|
[`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?))) #t]
|
|
[`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?) ,(? number?))) #t]
|
|
[else #f]))
|
|
|
|
;; add-keybindings-item : keybindings-item[path or planet spec] -> boolean
|
|
;; boolean indicates if the addition happened sucessfully
|
|
(define (add-keybindings-item item)
|
|
(with-handlers ([exn:fail?
|
|
(λ (x)
|
|
(message-box (string-constant drscheme)
|
|
(format (string-constant keybindings-error-installing-file)
|
|
(if (path? item)
|
|
(path->string item)
|
|
(format "~s" item))
|
|
(exn-message x))
|
|
#:dialog-mixin frame:focus-table-mixin)
|
|
#f)])
|
|
(keymap:add-user-keybindings-file item)
|
|
#t))
|
|
|
|
(define (remove-keybindings-item item)
|
|
(keymap:remove-user-keybindings-file item)
|
|
(preferences:set
|
|
'drracket:user-defined-keybindings
|
|
(remove item
|
|
(preferences:get 'drracket:user-defined-keybindings))))
|
|
|
|
;; install-plt-file : (union #f dialog% frame%) -> void
|
|
;; asks the user for a .plt file, either from the web or from
|
|
;; a file on the disk and installs it.
|
|
(define (install-plt-file parent)
|
|
(define pref (preferences:get 'drracket:install-plt-dialog))
|
|
(define dialog
|
|
(new dialog% [parent parent]
|
|
[label (string-constant install-plt-file-dialog-title)]
|
|
[alignment '(left center)]))
|
|
(define tab-panel
|
|
(new tab-panel% [parent dialog]
|
|
[callback (λ (x y) (update-panels))]
|
|
[choices (list (string-constant install-plt-web-tab)
|
|
(string-constant install-plt-file-tab))]))
|
|
(define outer-swapping-panel
|
|
(new horizontal-panel% [parent tab-panel]
|
|
[stretchable-height #f]))
|
|
(define spacing-panel
|
|
(new horizontal-panel% [parent outer-swapping-panel]
|
|
[stretchable-width #f]
|
|
[min-width 20]))
|
|
(define swapping-panel
|
|
(new panel:single% [parent outer-swapping-panel]
|
|
[alignment '(left center)]
|
|
[stretchable-width #t] [stretchable-height #f]))
|
|
(define file-panel
|
|
(new horizontal-panel% [parent swapping-panel]
|
|
[stretchable-width #t] [stretchable-height #f]))
|
|
(define url-panel
|
|
(new horizontal-panel% [parent swapping-panel]
|
|
[stretchable-height #f]))
|
|
(define button-panel
|
|
(new horizontal-panel% [parent dialog]
|
|
[stretchable-height #f] [alignment '(right center)]))
|
|
(define file-text-field
|
|
(new text-field% [parent file-panel]
|
|
[callback void] [min-width 300] [stretchable-width #t]
|
|
[init-value (caddr pref)]
|
|
[label (string-constant install-plt-filename)]))
|
|
(define file-button
|
|
(new button% [parent file-panel]
|
|
[callback (λ (x y) (browse))]
|
|
[label (string-constant browse...)]))
|
|
(define url-text-field
|
|
(new text-field% [parent url-panel]
|
|
[min-width 300] [stretchable-width #t] [callback void]
|
|
[init-value (cadr pref)]
|
|
[label (string-constant install-plt-url)]))
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons
|
|
button-panel
|
|
(λ (x y) (set! cancel? #f) (send dialog show #f))
|
|
(λ (x y) (send dialog show #f))))
|
|
;; browse : -> void
|
|
;; gets the name of a file from the user and updates file-text-field
|
|
(define (browse)
|
|
(let ([filename (parameterize ([finder:default-extension "plt"]
|
|
[finder:default-filters
|
|
(if (eq? (system-type) 'macosx)
|
|
(finder:default-filters)
|
|
'(("PLT Files" "*.plt")
|
|
("Any" "*.*")))])
|
|
(finder:get-file #f "" #f "" dialog))])
|
|
(when filename
|
|
(send file-text-field set-value (path->string filename)))))
|
|
;; from-web? : -> boolean
|
|
;; returns #t if the user has selected a web address
|
|
(define (from-web?)
|
|
(zero? (send tab-panel get-selection)))
|
|
(define cancel? #t)
|
|
(define (update-panels)
|
|
(define w? (from-web?))
|
|
(define t (if w? url-text-field file-text-field))
|
|
(send swapping-panel active-child (if w? url-panel file-panel))
|
|
(send t focus)
|
|
(send (send t get-editor) set-position
|
|
0 (string-length (send t get-value))))
|
|
;; initialize
|
|
(send tab-panel set-selection (if (car pref) 0 1))
|
|
(update-panels)
|
|
(send dialog show #t)
|
|
(preferences:set 'drracket:install-plt-dialog
|
|
(list (from-web?)
|
|
(send url-text-field get-value)
|
|
(send file-text-field get-value)))
|
|
(cond
|
|
[cancel? (void)]
|
|
[(from-web?)
|
|
(install-plt-from-url
|
|
(let* ([url (send url-text-field get-value)]
|
|
;; trim whitespaces
|
|
[url (regexp-replace #rx"^ +" url "")]
|
|
[url (regexp-replace #rx" +$" url "")])
|
|
(if (regexp-match? #rx"^(?:[^/:]*://|$)" url)
|
|
url
|
|
(string-append "http://" url)))
|
|
parent)]
|
|
[else (parameterize ([error-display-handler
|
|
drracket:init:original-error-display-handler])
|
|
(run-installer
|
|
(string->path (send file-text-field get-value))))]))
|
|
|
|
;; install-plt-from-url : string (union #f dialog%) -> void
|
|
;; downloads and installs a .plt file from the given url
|
|
(define (install-plt-from-url s-url parent)
|
|
(define-values (port size)
|
|
(let-values ([(port header)
|
|
(get-pure-port/headers (string->url s-url)
|
|
#:redirections 5)])
|
|
(define size
|
|
(let* ([content-header (extract-field "content-length" header)]
|
|
[m (and content-header
|
|
(regexp-match "[0-9]+" content-header))])
|
|
(and m (string->number (car m)))))
|
|
(values port size)))
|
|
(let* ([tmp-filename (make-temporary-file "tmp~a.plt")]
|
|
[header (purify-port port)]
|
|
[d (make-object dialog% (string-constant downloading) parent)]
|
|
[message (make-object message% (string-constant downloading-file...) d)]
|
|
[gauge (if size
|
|
(make-object gauge% #f 100 d)
|
|
#f)]
|
|
[exn #f]
|
|
; Semaphores to avoid race conditions:
|
|
[wait-to-start (make-semaphore 0)]
|
|
[wait-to-break (make-semaphore 0)]
|
|
; Thread to perform the download:
|
|
[t (thread
|
|
(λ ()
|
|
(semaphore-wait wait-to-start)
|
|
(with-handlers ([exn:fail?
|
|
(λ (x)
|
|
(set! exn x))]
|
|
[exn:break? ; throw away break exceptions
|
|
void])
|
|
(semaphore-post wait-to-break)
|
|
(with-output-to-file tmp-filename
|
|
(λ ()
|
|
(let loop ([total 0])
|
|
(when gauge
|
|
(send gauge set-value
|
|
(inexact->exact
|
|
(floor (* 100 (/ total size))))))
|
|
(let ([s (read-string 1024 port)])
|
|
(unless (eof-object? s)
|
|
(unless (eof-object? s)
|
|
(display s)
|
|
(loop (+ total (string-length s))))))))
|
|
#:mode 'binary #:exists 'truncate))
|
|
(send d show #f)))])
|
|
(send d center)
|
|
(make-object button% (string-constant &stop)
|
|
d
|
|
(λ (b e)
|
|
(semaphore-wait wait-to-break)
|
|
(set! tmp-filename #f)
|
|
(send d show #f)
|
|
(break-thread t)))
|
|
; Let thread run only after the dialog is shown
|
|
(queue-callback (λ () (semaphore-post wait-to-start)))
|
|
(send d show #t)
|
|
(when exn (raise exn))
|
|
(define unpack-err (open-output-string))
|
|
(cond
|
|
[(with-handlers ((exn:fail? values))
|
|
(parameterize ([error-display-handler drracket:init:original-error-display-handler]
|
|
[current-error-port unpack-err])
|
|
(fold-plt-archive tmp-filename void void void void void))
|
|
#f)
|
|
=>
|
|
(λ (exn)
|
|
(delete-file tmp-filename)
|
|
(message-box (string-constant drscheme)
|
|
(string-append
|
|
(string-constant install-plt-error-header)
|
|
"\n\n"
|
|
(exn-message exn)
|
|
"\n\n"
|
|
(get-output-string unpack-err))
|
|
#:dialog-mixin frame:focus-table-mixin))]
|
|
[else
|
|
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
|
|
(run-installer tmp-filename
|
|
(λ ()
|
|
(delete-file tmp-filename))))])))
|
|
|
|
(define keybindings-frame%
|
|
(class frame%
|
|
(init-field bindings)
|
|
|
|
(define/override (on-size w h)
|
|
(preferences:set 'drracket:keybindings-window-size (cons w h))
|
|
(super on-size w h))
|
|
|
|
(super-new)
|
|
|
|
(define/public (set-bindings _bindings)
|
|
(set! bindings _bindings)
|
|
(update-bindings))
|
|
|
|
(define bp (make-object horizontal-panel% this))
|
|
(define search-field (new text-field%
|
|
[parent this]
|
|
[label (string-constant mfs-search-string)]
|
|
[callback (λ (a b) (update-bindings))]))
|
|
(define b-name (new button%
|
|
[label (string-constant keybindings-sort-by-name)]
|
|
[parent bp]
|
|
[callback
|
|
(λ x
|
|
(set! by-key? #f)
|
|
(update-bindings))]))
|
|
(define b-key (new button%
|
|
[label (string-constant keybindings-sort-by-key)]
|
|
[parent bp]
|
|
[callback (λ x
|
|
(set! by-key? #t)
|
|
(update-bindings))]))
|
|
(define lb (new list-box% [parent this] [label #f] [choices '()]))
|
|
(define by-key? #f)
|
|
(define bp2 (make-object horizontal-panel% this))
|
|
(define cancel (make-object button% (string-constant close)
|
|
bp2 (λ x (send this show #f))))
|
|
|
|
(define/private (update-bindings)
|
|
(let ([format-binding/name
|
|
(λ (b) (format "~a (~a)" (cadr b) (car b)))]
|
|
[format-binding/key
|
|
(λ (b) (format "~a (~a)" (car b) (cadr b)))]
|
|
[predicate/key
|
|
(λ (a b) (string-ci<=? (format "~a" (car a))
|
|
(format "~a" (car b))))]
|
|
[predicate/name
|
|
(λ (a b) (string-ci<=? (cadr a) (cadr b)))])
|
|
(send lb set
|
|
(if by-key?
|
|
(map format-binding/key (sort (filter-search bindings) predicate/key))
|
|
(map format-binding/name (sort (filter-search bindings) predicate/name))))))
|
|
|
|
(define/private (filter-search bindings)
|
|
(let ([str (send search-field get-value)])
|
|
(if (equal? str "")
|
|
bindings
|
|
(let ([reg (regexp (regexp-quote str #f))])
|
|
(filter (λ (x) (or (regexp-match reg (cadr x))
|
|
(regexp-match reg (format "~a" (car x)))))
|
|
bindings)))))
|
|
(send search-field focus)
|
|
(send bp stretchable-height #f)
|
|
(send bp set-alignment 'center 'center)
|
|
(send bp2 stretchable-height #f)
|
|
(send bp2 set-alignment 'right 'center)
|
|
(update-bindings)))
|
|
|
|
(define the-keybindings-frame #f)
|
|
|
|
(define (show-keybindings-to-user bindings frame)
|
|
(unless the-keybindings-frame
|
|
(set! the-keybindings-frame
|
|
(new keybindings-frame%
|
|
[label (string-constant keybindings-frame-title)]
|
|
[width (car (preferences:get 'drracket:keybindings-window-size))]
|
|
[height (cdr (preferences:get 'drracket:keybindings-window-size))]
|
|
[bindings bindings])))
|
|
(send the-keybindings-frame show #t))
|
|
|
|
(define -mixin
|
|
(mixin (frame:editor<%> frame:text-info<%> drracket:frame:basics<%>) (drracket:frame:<%>)
|
|
(inherit get-editor get-menu% get-menu-bar)
|
|
(define show-menu #f)
|
|
(define/public get-show-menu (λ () show-menu))
|
|
(define/public update-shown (λ () (void)))
|
|
(define/public (add-show-menu-items show-menu) (void))
|
|
(define sort-menu-sort-keys (make-hasheq))
|
|
(define/public (set-show-menu-sort-key item val)
|
|
(cond
|
|
[sort-menu-sort-keys
|
|
(for ([(k v) (in-hash sort-menu-sort-keys)])
|
|
(when (eq? k item)
|
|
(error 'set-show-menu-sort-key
|
|
"set menu item ~s twice, to ~s and ~s"
|
|
(send item get-label)
|
|
v val))
|
|
(when (= v val)
|
|
(error 'set-show-menu-sort-key
|
|
"two menu items have the same val: ~s and ~s"
|
|
(send k get-label)
|
|
(send item get-label))))
|
|
(hash-set! sort-menu-sort-keys item val)]
|
|
[else
|
|
(error 'set-show-menu-sort-key
|
|
"the sort menu has already been created and its order has been set")]))
|
|
(super-new)
|
|
(set! show-menu (make-object (get-menu%) (string-constant view-menu-label)
|
|
(get-menu-bar)))
|
|
(add-show-menu-items show-menu)
|
|
(sort-show-menu-items show-menu sort-menu-sort-keys)
|
|
(set! sort-menu-sort-keys #f)))
|
|
|
|
(define (sort-show-menu-items show-menu show-menu-sort-keys)
|
|
(define items (send show-menu get-items))
|
|
(for ([itm (in-list items)])
|
|
(send itm delete))
|
|
(define (get-key item)
|
|
(hash-ref show-menu-sort-keys item
|
|
(λ ()
|
|
(define lab
|
|
(cond
|
|
[(is-a? item labelled-menu-item<%>)
|
|
(send item get-label)]
|
|
[else ""]))
|
|
(cond
|
|
[(regexp-match #rx"^Show (.*)$" lab)
|
|
=> (λ (x) (list-ref x 1))]
|
|
[(regexp-match #rx"^Hide (.*)$" lab)
|
|
=> (λ (x) (list-ref x 1))]
|
|
[else lab]))))
|
|
(define (cmp item-x item-y)
|
|
(define x (get-key item-x))
|
|
(define y (get-key item-y))
|
|
(cond
|
|
[(and (number? x) (number? y)) (< x y)]
|
|
[(and (string? x) (string? y)) (string<=? x y)]
|
|
[(and (number? x) (string? y)) #t]
|
|
[(and (string? x) (number? y)) #f]))
|
|
(define sorted-items (sort items cmp))
|
|
|
|
(define (different-slots? item-key next-item-key)
|
|
(or (not (= (quotient item-key 100)
|
|
(quotient next-item-key 100)))
|
|
(not (= (sgn item-key)
|
|
(sgn next-item-key)))))
|
|
|
|
(for ([item (in-list sorted-items)]
|
|
[next-item (in-list (append (cdr sorted-items) (list #f)))])
|
|
(define item-key (get-key item))
|
|
(define next-item-key (and next-item (get-key next-item)))
|
|
(define add-sep?
|
|
(cond
|
|
[(and (number? item-key) (number? next-item-key))
|
|
(different-slots? item-key next-item-key)]
|
|
[(or (and (string? item-key) (string? next-item-key))
|
|
(not next-item-key))
|
|
#f]
|
|
[else #t]))
|
|
(send item restore)
|
|
(when add-sep?
|
|
(new separator-menu-item% [parent show-menu]))))
|
|
|
|
|
|
(define (create-root-menubar)
|
|
(define mb (new menu-bar% (parent 'root)))
|
|
(define file-menu (new menu%
|
|
(label (string-constant file-menu))
|
|
(parent mb)))
|
|
(define help-menu (new menu%
|
|
(label (string-constant help-menu))
|
|
(parent mb)))
|
|
(new menu-item%
|
|
(label (string-constant new-menu-item))
|
|
(parent file-menu)
|
|
(shortcut #\n)
|
|
(callback
|
|
(λ (x y)
|
|
(handler:edit-file #f)
|
|
#t)))
|
|
(new menu-item%
|
|
(label (string-constant open-menu-item))
|
|
(parent file-menu)
|
|
(shortcut #\o)
|
|
(callback
|
|
(λ (x y)
|
|
(handler:open-file)
|
|
#t)))
|
|
(new menu%
|
|
(label (string-constant open-recent-menu-item))
|
|
(parent file-menu)
|
|
(demand-callback
|
|
(λ (menu)
|
|
(handler:install-recent-items menu))))
|
|
(new menu-item%
|
|
[label (string-constant mfs-multi-file-search-menu-item)]
|
|
[parent file-menu]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(drracket:multi-file-search:multi-file-search))])
|
|
(unless (current-eventspace-has-standard-menus?)
|
|
(new separator-menu-item% (parent file-menu))
|
|
(new menu-item%
|
|
(label (string-constant quit-menu-item-others))
|
|
(parent file-menu)
|
|
(shortcut #\q)
|
|
(callback
|
|
(λ (x y)
|
|
(when (exit:user-oks-exit)
|
|
(exit:exit))
|
|
#t))))
|
|
(make-help-desk-menu-item help-menu)
|
|
(drracket-help-menu:after-about help-menu #f))
|
|
|
|
(define (make-help-desk-menu-item help-menu)
|
|
(define (docs-menu-item label)
|
|
(new menu-item%
|
|
[label label]
|
|
[parent help-menu]
|
|
[callback (λ (item evt) (help:help-desk) #t)]))
|
|
(docs-menu-item (string-constant racket-documentation))
|
|
(new separator-menu-item% [parent help-menu])
|
|
(docs-menu-item (string-constant help-desk)))
|
|
|
|
(define (drracket-help-menu:after-about menu dlg-parent)
|
|
(drracket:app:add-important-urls-to-help-menu menu '())
|
|
(new menu-item%
|
|
[label (string-constant bug-report-submit-menu-item)]
|
|
[parent menu]
|
|
[callback
|
|
(λ (x y)
|
|
(define saved (saved-bug-report-titles/ids))
|
|
(cond
|
|
[(null? saved)
|
|
(help-desk:report-bug #f #:frame-mixin basics-mixin)]
|
|
[else
|
|
(define which #f)
|
|
(define (done the-one)
|
|
(set! which the-one)
|
|
(send dlg show #f))
|
|
(define dlg (new dialog%
|
|
[label (string-constant drscheme)]
|
|
[parent dlg-parent]))
|
|
(define btn1 (new button%
|
|
[parent dlg]
|
|
[label (string-constant new-bug-report)]
|
|
[callback (λ (x y) (done #f))]))
|
|
(new message% [parent dlg] [label (string-constant saved-unsubmitted-bug-reports)])
|
|
(define btns
|
|
(cons btn1
|
|
(for/list ([a-brinfo (in-list saved)])
|
|
(new button%
|
|
[parent dlg]
|
|
[label (brinfo-title a-brinfo)]
|
|
[callback
|
|
(λ (x y) (done (brinfo-id a-brinfo)))]))))
|
|
(define width (apply max (map (λ (x) (let-values ([(w h) (send x get-client-size)]) w))
|
|
btns)))
|
|
(for ([x (in-list btns)])
|
|
(send x min-width width))
|
|
(send btn1 focus)
|
|
(send dlg show #t)
|
|
(help-desk:report-bug which #:frame-mixin basics-mixin)]))])
|
|
(new menu%
|
|
[label (string-constant saved-bug-reports-menu-item)]
|
|
[parent menu]
|
|
[demand-callback
|
|
(let ([last-time (gensym)]) ;; a unique thing to guarantee the menu is built the first time
|
|
(λ (saved-bug-reports-menu)
|
|
(define this-time (saved-bug-report-titles/ids))
|
|
(unless (equal? last-time this-time)
|
|
(set! last-time this-time)
|
|
(for ([x (in-list (send saved-bug-reports-menu get-items))])
|
|
(send x delete))
|
|
(cond
|
|
[(null? this-time)
|
|
(send (new menu-item%
|
|
[parent saved-bug-reports-menu]
|
|
[label (string-constant no-saved-bug-reports)]
|
|
[callback void])
|
|
enable #f)]
|
|
[else
|
|
(for ([a-brinfo (in-list this-time)])
|
|
(new menu-item%
|
|
[parent saved-bug-reports-menu]
|
|
[label (brinfo-title a-brinfo)]
|
|
[callback
|
|
(λ (x y)
|
|
(help-desk:report-bug (brinfo-id a-brinfo) #:frame-mixin basics-mixin))]))
|
|
(new separator-menu-item% [parent saved-bug-reports-menu])
|
|
(new menu-item%
|
|
[parent saved-bug-reports-menu]
|
|
[label (string-constant disacard-all-saved-bug-reports)]
|
|
[callback (λ (x y) (discard-all-saved-bug-reports))])]))))])
|
|
(drracket:app:add-language-items-to-help-menu menu)))
|
|
|
|
|