#lang racket/base

(module install-pkg racket/base
  (require racket/gui/base 
           racket/class
           string-constants
           planet2/name
           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 (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) (adjust-all))]))
    
    (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 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 (adjust-all)
      (adjust-inferred)
      (adjust-cmd-line)
      (adjust-details-shown)
      (adjust-ok/cancel))
    
    (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 install "
                 (apply string-append
                        (add-between 
                         (filter values (map convert-to-string cmd-line))
                         " ")))
                "")))
    
    (define (compute-cmd-line)
      (define the-pkg (send tf get-value))
      (and (not (equal? the-pkg ""))
           (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
         planet2
         (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
                  (with-handlers ((exn:fail?
                                   (λ (x)
                                     (define sp (open-output-string))
                                     (parameterize ([current-error-port sp])
                                       (drracket:init:original-error-display-handler
                                        (exn-message x) 
                                        x))
                                     (message-box (string-constant install-pkg-error-installing-title)
                                                  (get-output-string sp)))))
                    (apply install 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)))