
(module group mzscheme
  (require (lib "string-constant.ss" "string-constants")
           (lib "unitsig.ss")
           (lib "class.ss")
           "sig.ss"
	   "../gui-utils.ss"
           (lib "mred-sig.ss" "mred")
           (lib "list.ss")
           (lib "file.ss"))
  
  (provide group@)
  
  (define group@
    (unit/sig framework:group^
      (import mred^
              [application : framework:application^]
              [frame : framework:frame^]
              [preferences : framework:preferences^]
              [text : framework:text^]
              [canvas : framework:canvas^]
              [menu : framework:menu^])
      
      (define-struct frame (frame id))
      
      (define mdi-parent #f)
      
      (define %
        (class object%
          
          [define active-frame #f]
          [define most-recent-window-box (make-weak-box #f)]
          [define frame-counter 0]
          [define frames null]
          [define todo-to-new-frames void]

          [define windows-menus null]
          
          ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%))
          (define/private (get-windows-menu frame)
            (let ([menu-bar (send frame get-menu-bar)])
              (and menu-bar
                   (let ([menus (send menu-bar get-items)])
                     (ormap (λ (x)
                              (if (string=? (string-constant windows-menu)
                                            (send x get-plain-label))
                                  x
                                  #f))
                            menus)))))
          
          (define/private (insert-windows-menu frame)
            (let ([menu (get-windows-menu frame)])
              (when menu
                (set! windows-menus (cons menu windows-menus)))))
          
          (define/private (remove-windows-menu frame)
            (let ([menu (get-windows-menu frame)])
              
              (when menu
                ;; to help the (conservative) gc.
                (for-each (λ (i) (send i delete)) (send menu get-items))
                
                (set! windows-menus
                      (remove
                       menu
                       windows-menus
                       eq?)))))
          
          (define/private (update-windows-menus)
            (let* ([windows (length windows-menus)]
                   [default-name (string-constant untitled)]
                   [get-name 
                    (λ (frame)
                      (let ([label (send frame get-label)])
                        (if (string=? label "")
                            (if (method-in-interface? 'get-entire-label (object-interface frame))
                                (let ([label (send frame get-entire-label)])
                                  (if (string=? label "")
                                      default-name
                                      label))
                                default-name)
                            label)))]
                   [sorted/visible-frames
                    (quicksort
                     (filter (λ (x) (send (frame-frame x) is-shown?)) frames)
                     (λ (f1 f2)
                       (string-ci<=? (get-name (frame-frame f1))
                                     (get-name (frame-frame f2)))))])
              (for-each
               (λ (menu)
                 (for-each (λ (item) (send item delete)) (send menu get-items))
                 (instantiate menu:can-restore-menu-item% ()
                   (label (string-constant bring-frame-to-front...))
                   (parent menu)
                   (callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
                   (shortcut #\j))
                 (instantiate menu:can-restore-menu-item% ()
                   (label (string-constant most-recent-window))
                   (parent menu)
                   (callback (λ (x y) (most-recent-window-to-front)))
                   (shortcut #\'))
                 (make-object separator-menu-item% menu)
                 (for-each
                  (λ (frame)
                    (let ([frame (frame-frame frame)])
                      (make-object menu-item% 
                        (regexp-replace*
                         "&"
                         (gui-utils:trim-string (get-name frame) 200)
                         "&&")
                        menu
                        (λ (_1 _2)
                          (send frame show #t)))))
                  sorted/visible-frames))
               windows-menus)))

          ;; most-recent-window-to-front : -> void?
          ;; brings the most recent window to the front
          (define/private (most-recent-window-to-front)
            (let ([most-recent-window (weak-box-value most-recent-window-box)])
              (when most-recent-window
                (send most-recent-window show #t))))                              

          (define/private (update-close-menu-item-state)
            (let* ([set-close-menu-item-state! 
                    (λ (frame state)
                      (when (is-a? frame frame:standard-menus<%>)
                        (let ([close-menu-item (send frame file-menu:get-close-menu)])
                          (when close-menu-item
                            (send close-menu-item enable state)))))])
              (if (eq? (length frames) 1)
                  (set-close-menu-item-state! (car frames) #f)
                  (for-each (λ (a-frame)
                              (set-close-menu-item-state! a-frame #t))
                            frames))))
          
          (field [open-here-frame #f])
          (define/public (set-open-here-frame fr) (set! open-here-frame fr))
          (define/public (get-open-here-frame)
	    (cond
              [open-here-frame open-here-frame]
              [else
               (let ([candidates
                      (filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>))
                              frames)])
                 (if (null? candidates)
                     #f
                     (frame-frame (car candidates))))]))
          
          (public get-mdi-parent frame-label-changed for-each-frame
                  get-active-frame set-active-frame insert-frame
                  remove-frame clear on-close-all can-close-all? locate-file get-frames
                  frame-shown/hidden)
          (define (get-mdi-parent)
            (when (and (eq? (system-type) 'windows)
                       (preferences:get 'framework:windows-mdi)
                       (not mdi-parent))
              (set! mdi-parent (make-object frame% (application:current-app-name)
                                 #f #f #f #f #f
                                 '(mdi-parent)))
              (send mdi-parent show #t))
            mdi-parent)
          
          (define (get-frames) (map frame-frame frames))
          
          (define (frame-label-changed frame)
            (when (memq frame (map frame-frame frames))
              (update-windows-menus)))
          
          (define (frame-shown/hidden frame)
            (when (memq frame (map frame-frame frames))
              (update-windows-menus)))
          
          (define (for-each-frame f)
            (for-each (λ (x) (f (frame-frame x))) frames)
            (set! todo-to-new-frames
                  (let ([old todo-to-new-frames])
                    (λ (frame) (old frame) (f frame)))))
          
          (define (get-active-frame)
            (cond
              [active-frame active-frame]
              [(null? frames) #f]
              [else (frame-frame (car frames))]))
          
          (define (set-active-frame f)
            (when (and active-frame
                       (not (eq? active-frame f)))
              (set! most-recent-window-box (make-weak-box active-frame)))
            (set! active-frame f))
          
          (define (insert-frame new-frame)
            (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame))
                          frames)
              (set! frame-counter (add1 frame-counter))
              (let ([new-frames (cons (make-frame new-frame frame-counter)
                                      frames)])
                (set! frames new-frames)
                (update-close-menu-item-state)
                (insert-windows-menu new-frame)
                (update-windows-menus))
              (todo-to-new-frames new-frame)))
          
          (define (remove-frame f)
            (when (eq? f active-frame)
              (set! active-frame #f))
            (let ([new-frames
                   (remove
                    f frames
                    (λ (f fr) (eq? f (frame-frame fr))))])
              (set! frames new-frames)
              (update-close-menu-item-state)
              (remove-windows-menu f)
              (update-windows-menus)))
          
          (define (clear)
            (set! frames null)
            #t)
          
          (define (on-close-all)
            (for-each (λ (f)
                        (let ([frame (frame-frame f)])
                          (send frame on-close) 
                          (send frame show #f)))
                      frames))
          
          (define (can-close-all?)
            (andmap (λ (f)
                      (let ([frame (frame-frame f)])
                        (send frame can-close?)))
                    frames))
          
          (define (locate-file name)
            (let* ([normalized
                    ;; allow for the possiblity of filenames that are urls
                    (with-handlers ([(λ (x) #t)
                                     (λ (x) name)])
                      (normal-case-path
                       (normalize-path name)))]
                   [test-frame
                    (λ (frame)
                      (and (is-a? frame frame:basic<%>)
                           (send frame editing-this-file? normalized)))])
              (let loop ([frames frames])
                (cond
                  [(null? frames) #f]
                  [else
                   (let* ([frame (frame-frame (car frames))])
                     (if (test-frame frame)
                         frame
                         (loop (cdr frames))))]))))
          
          (super-new)))
      
      (define (choose-a-frame parent)
        (letrec-values ([(sorted-frames)
                         (quicksort
                          (send (get-the-frame-group) get-frames)
                          (λ (x y) (string-ci<=? (send x get-label) (send y get-label))))]
                        [(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
                        [(lb) (instantiate list-box% () 
                              (label #f)
                              (choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
                              (callback (λ (x y) (listbox-callback y)))
                              (parent d))]
                        [(t) (instantiate text:hide-caret/selection% ())]
                        [(ec) (instantiate canvas:basic% ()
                              (parent d)
                              (stretchable-height #f))]
                        [(bp) (instantiate horizontal-panel% ()
                              (parent d)
                              (stretchable-height #f)
                              (alignment '(right center)))]
                        [(cancelled?) #t]
                        [(listbox-callback)
                         (λ (evt)
                           (case (send evt get-event-type)
                             [(list-box)
                              
                              (send ok enable (pair? (send lb get-selections)))
                              
                              (let ([full-name
                                     (let ([sels (send lb get-selections)])
                                       (and (pair? sels)
                                            (let ([fr (list-ref sorted-frames (car sels))])
                                              (and (is-a? fr frame:basic%)
                                                   (send fr get-filename)))))])
                                (send t begin-edit-sequence)
                                (send t erase)
                                (when full-name
                                  (send t insert full-name))
                                (send t end-edit-sequence))]
                             [(list-box-dclick)
                              (set! cancelled? #f)
                              (send d show #f)]))]
                        [(ok cancel)
                         (gui-utils:ok/cancel-buttons
                          bp
                          (λ (x y)
                            (set! cancelled? #f)
                            (send d show #f))
                          (λ (x y)
                            (send d show #f)))])
          (send ec set-line-count 3)
          (send ec set-editor t)
          (send t auto-wrap #t)
          (let ([fr (car sorted-frames)])
            (when (and (is-a? fr frame:basic<%>)
                       (send fr get-filename))
              (send t insert (send (car sorted-frames) get-filename)))
            (send lb set-selection 0))
          (send d show #t)
          (unless cancelled?
            (let ([sels (send lb get-selections)])
              (unless (null? sels)
                (send (list-ref sorted-frames (car sels)) show #t))))))
      
      
      (define (internal-get-the-frame-group)
        (let ([the-frame-group (make-object %)])
          (set! internal-get-the-frame-group (λ () the-frame-group))
          (internal-get-the-frame-group)))
      
      (define (get-the-frame-group)
        (internal-get-the-frame-group)))))
