#lang scheme/unit
  (require string-constants
           racket/match
           racket/class
           racket/string
           "drsig.rkt"
           mred
           framework
           net/url
           net/head
           setup/plt-installer
           help/bug-report
           racket/file)
  
  (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^])
  (export (rename drracket:frame^
                  [-mixin mixin]))
  
  (define basics<%> (interface (frame:standard-menus<%>)))
  
  (define last-keybindings-planet-attempt "")
  
  (define basics-mixin
    (mixin (frame:standard-menus<%>) (basics<%>)
      
      (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 (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<%>)))))
      
      (define/private (show-keybindings)
        (if (can-show-keybindings?)
            (let* ([edit-object (get-edit-target-object)]
                   [keymap (send edit-object get-keymap)]
                   [menu-names (get-menu-bindings)]
                   [table (send keymap get-map-function-table)]
                   [bindings (hash-map table list)]
                   [w/menus 
                    (append (hash-map menu-names list)
                            (filter (λ (binding) (not (bound-by-menu? binding menu-names)))
                                    bindings))]
                   [structured-list
                    (sort
                     w/menus
                     (λ (x y) (string-ci<=? (cadr x) (cadr y))))])
              (show-keybindings-to-user structured-list 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:app:add-important-urls-to-help-menu
         menu 
         (get-additional-important-urls))
        (new menu-item%
             (label (string-constant bug-report-submit-menu-item))
             (parent menu)
             (callback
              (λ (x y)
                (help-desk:report-bug))))
        
        (drracket:app:add-language-items-to-help-menu menu))
      
      (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) 
        (make-object menu-item% 
          (string-constant install-plt-file-menu-item...)
          file-menu
          (λ (item evt)
            (install-plt-file this)))
        (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)
        (make-object separator-menu-item% 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))]))))))
               (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? (λ (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)))
                            #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 (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)
    (with-handlers ([(λ (x) #f)
                     (λ (exn)
                       (message-box (string-constant drscheme)
                                    (if (exn? exn)
                                        (format "~a" (exn-message exn))
                                        (format "~s" exn))))])
      (let* ([url (string->url s-url)]
             [tmp-filename (make-temporary-file "tmp~a.plt")]
             [port (get-impure-port url)]
             [header (purify-port port)]
             [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))))]
             [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))
        (parameterize ([error-display-handler drracket:init:original-error-display-handler])
          (run-installer tmp-filename
                         (λ ()
                           (delete-file tmp-filename)))))))
  
  
  (define keybindings-dialog%
    (class dialog%
      (override on-size)
      [define on-size
        (lambda (w h)
          (preferences:set 'drracket:keybindings-window-size (cons w h))
          (super on-size w h))]
      (super-instantiate ())))
  
  (define (show-keybindings-to-user bindings frame)
    (letrec ([f (instantiate keybindings-dialog% ()
                  (label (string-constant keybindings-frame-title))
                  (parent frame)
                  (width (car (preferences:get 'drracket:keybindings-window-size)))
                  (height (cdr (preferences:get 'drracket:keybindings-window-size)))
                  (style '(resize-border)))]
             [bp (make-object horizontal-panel% f)]
             [search-field (new text-field% 
                                [parent f]
                                [label (string-constant mfs-search-string)]
                                [callback (λ (a b) (update-bindings))])]
             [b-name (make-object button% (string-constant keybindings-sort-by-name)
                       bp (λ x 
                            (set! by-key? #f)
                            (update-bindings)))]
             [b-key (make-object button% (string-constant keybindings-sort-by-key)
                      bp (λ x 
                           (set! by-key? #t)
                           (update-bindings)))]
             [lb
              (make-object list-box% #f null f void)]
             [bp2 (make-object horizontal-panel% f)]
             [cancel (make-object button% (string-constant close)
                       bp2 (λ x (send f show #f)))]
             [space (make-object grow-box-spacer-pane% bp2)]
             [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)))))]
             [by-key? #f]
             [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))))))])
      (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)
      (send f show #t)))
  
  (define <%>
    (interface (frame:editor<%> basics<%> frame:text-info<%>)
      get-show-menu
      update-shown
      add-show-menu-items))
  
  (define -mixin
    (mixin (frame:editor<%> frame:text-info<%> basics<%>) (<%>)
      (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))
      (super-new)
      (set! show-menu (make-object (get-menu%) (string-constant view-menu-label)
                        (get-menu-bar)))
      (add-show-menu-items show-menu)))
  
  
  (define (create-root-menubar)
    (let* ([mb (new menu-bar% (parent 'root))]
           [file-menu (new menu% 
                           (label (string-constant file-menu))
                           (parent mb))]
           [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))))
      (instantiate 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)))
  
  (define (make-help-desk-menu-item help-menu)
    (make-object menu-item%
      (string-constant help-desk)
      help-menu
      (λ (item evt)
        (help:help-desk)
        #t)))
