(module mrtop mzscheme
  (require mzlib/class
	   mzlib/class100
	   mzlib/etc
	   mzlib/list
	   (prefix wx: "kernel.ss")
	   "lock.ss"
	   "helper.ss"
	   "const.ss"
	   "kw.ss"
	   "check.ss"
	   "wx.ss"
	   "wxtop.ss"
	   "wxpanel.ss"
	   "wxitem.ss"
	   "mrwindow.ss"
	   "mrcontainer.ss"
           "app.ss")

  (provide top-level-window<%>
	   frame%
	   dialog%
	   (protect root-menu-frame)
	   get-top-level-windows
	   get-top-level-focus-window
	   get-top-level-edit-target-window
	   send-message-to-window
	   (protect check-top-level-parent/false
		    check-frame-parent/false))

  (define top-level-window<%>
    (interface (area-container-window<%>)
      get-eventspace
      on-activate on-traverse-char on-system-menu-char
      can-close? on-close
      can-exit? on-exit
      get-focus-window get-edit-target-window
      get-focus-object get-edit-target-object
      center move resize
      on-message))

  (define-keywords top-level-window%-keywords
    window%-keywords container%-keywords area%-keywords)

  (define-local-member-name
    do-create-status-line
    do-set-status-text)

  (define basic-top-level-window%
    (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) 
	       (mk-wx mismatches label parent)
      (inherit show)
      (rename [super-set-label set-label])
      (private
	[wx-object->proxy
	 (lambda (o)
	   (if (is-a? o wx:window%)
	       (wx->proxy o)
	       o))])
      (override
	[set-label (entry-point
		    (lambda (l)
		      (check-label-string/false '(method top-level-window<%> set-label) l)
		      (send wx set-title (or l ""))
		      (super-set-label l)))])
      (public
	[on-traverse-char (entry-point
			   (lambda (e)
			     (check-instance '(method top-level-window<%> on-traverse-char)
					     wx:key-event% 'key-event% #f e)
			     (send wx handle-traverse-key e)))]
	[on-system-menu-char (entry-point
			      (lambda (e)
				(check-instance '(method top-level-window<%> on-system-menu-char) 
						wx:key-event% 'key-event% #f e)
				(and (eq? #\space (send e get-key-code))
				     (send e get-meta-down)
				     (eq? 'windows (system-type))
				     (send wx system-menu) #t)))]
	[get-eventspace (entry-point (lambda () (send wx get-eventspace)))])
      (pubment
	[can-close? (lambda () (inner #t can-close?))]
	[on-close (lambda () (inner (void) on-close))])
      (public
	[can-exit? (lambda () (can-close?))]
	[on-exit (lambda () (on-close) (show #f))]
	[on-activate (lambda (x) (void))]
	[center (entry-point
		 (case-lambda
		  [() (send wx center 'both)]
		  [(dir) (send wx center dir)]))]
	[move (entry-point
	       (lambda (x y)
		 (check-slider-integer '(method top-level-window<%> move) x)
		 (check-slider-integer '(method top-level-window<%> move) y)
		 (send wx move x y)))]
	[resize (entry-point
		 (lambda (w h)
		   (check-range-integer '(method top-level-window<%> resize) w)
		   (check-range-integer '(method top-level-window<%> resize) h)
		   (send wx set-size -11111 -11111 w h)))]

	[get-focus-window (entry-point
			   (lambda () (let ([w (send wx get-focus-window)])
					(and w (wx->proxy w)))))]
	[get-edit-target-window (entry-point
				 (lambda () (let ([w (send wx get-edit-target-window)])
					      (and w (wx->proxy w)))))]
	[get-focus-object (entry-point
			   (lambda () (let ([o (send wx get-focus-object)])
					(and o (wx-object->proxy o)))))]
	[get-edit-target-object (entry-point
				 (lambda () (let ([o (send wx get-edit-target-object)])
					      (and o (wx-object->proxy o)))))]

	[on-message (lambda (m) (void))])
      (private-field
       [wx #f]
       [mid-panel #f] ;; supports status line
       [wx-panel #f]
       [status-message #f]
       [finish (entry-point
		(lambda (top-level hide-panel?)
		  (set! mid-panel (make-object wx-vertical-panel% #f this top-level null #f))
                  (send mid-panel skip-subwindow-events? #t)
                  (send (send mid-panel area-parent) add-child mid-panel)
		  (set! wx-panel (make-object wx-vertical-panel% #f this mid-panel null #f))
                  (send wx-panel skip-subwindow-events? #t)
		  (send (send wx-panel area-parent) add-child wx-panel)
		  (send top-level set-container wx-panel)
		  (when hide-panel?
		    (send mid-panel show #f))
		  top-level))])
      (public
        [do-create-status-line (lambda ()
                                 (unless status-message
                                   (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f))
                                   (send status-message stretchable-in-x #t)))]
        [do-set-status-text (lambda (s)
                              (when status-message
                                (send status-message set-label s)))])
      (override
        [get-client-handle (lambda () (send wx-panel get-client-handle))])
      (sequence 
	(super-init (lambda () (set! wx (mk-wx finish)) wx) 
                    (lambda () wx-panel) (lambda () mid-panel)
                    mismatches label parent arrow-cursor))))


  (define frame%
    (class100*/kw basic-top-level-window% ()
		  [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
		   top-level-window%-keywords]
      (inherit on-traverse-char on-system-menu-char
               do-create-status-line do-set-status-text)
      (sequence
	(let ([cwho '(constructor frame)])
	  (check-label-string cwho label)
	  (check-frame-parent/false cwho parent)
	  (check-dimension cwho width)
	  (check-dimension cwho height)
	  (check-init-pos-integer cwho x)
	  (check-init-pos-integer cwho y)
	  (check-style cwho #f '(no-resize-border no-caption no-system-menu 
						  mdi-parent mdi-child 
						  toolbar-button hide-menu-bar float metal) 
		       style)
	  (when (memq 'mdi-child style)
	    (when (memq 'mdi-parent style)
	      (raise-type-error (who->name cwho) 
				"style list, 'mdi-child and 'mdi-parent are mutually exclusive" 
				style)))))
      (rename [super-on-subwindow-char on-subwindow-char])
      (private-field
       [wx #f]
       [status-line? #f]
       [modified? #f])
      (override
	[on-subwindow-char (lambda (w event)
			     (super-on-subwindow-char w event)
			     (or (on-menu-char event)
				 (on-system-menu-char event)
				 (on-traverse-char event)))])
      (public
	[on-menu-char (entry-point
		       (lambda (e)
			 (check-instance '(method frame% on-menu-char) wx:key-event% 'key-event% #f e)
			 (send wx handle-menu-key e)))]
	[on-mdi-activate (lambda (on?) (void))]
	[on-toolbar-button-click (lambda () (void))]
	[create-status-line (entry-point (lambda () (unless status-line? (do-create-status-line) (set! status-line? #t))))]
	[set-status-text (lambda (s) (do-set-status-text s))]
	[has-status-line? (lambda () status-line?)]
	[iconize (entry-point (lambda (on?) (send wx iconize on?)))]
	[is-iconized? (entry-point (lambda () (send wx iconized?)))]
	[set-icon (case-lambda 
		   [(i) (send wx set-icon i)]
		   [(i b) (send wx set-icon i b)]
		   [(i b l?) (send wx set-icon i b l?)])]
	[maximize (entry-point (lambda (on?) (send wx position-for-initial-show) (send wx maximize on?)))]
        [is-maximized? (entry-point (lambda () (send wx is-maximized?)))]
	[get-menu-bar (entry-point (lambda () (let ([mb (send wx get-the-menu-bar)])
						(and mb (wx->mred mb)))))]
	[modified (entry-point
		   (case-lambda
		    [() modified?]
		    [(m) 
		     (set! modified? m)
		     (send wx set-modified m)]))])
      (sequence
	(as-entry
	 (lambda ()
	   (super-init 
	    (lambda (finish) 
	      (set! wx (finish (make-object wx-frame% this this
					    (and parent (mred->wx parent)) label
					    (or x -11111) (or y -11111)
					    (or width -1) (or height -1)
					    style)
			       (memq 'mdi-parent style)))
	      (send wx set-mdi-parent (memq 'mdi-parent style))
	      wx)
	    (lambda ()
	      (let ([cwho '(constructor frame)])
		(check-container-ready cwho parent)
		(when (memq 'mdi-child style)
		  (let ([pwx (and parent (mred->wx parent))])
		    (unless (and pwx (send pwx get-mdi-parent))
		      (raise-mismatch-error (who->name cwho) "parent for 'mdi-child frame is not an 'mdi-parent frame: " parent))))))
	    label parent))))))

  (define dialog%
    (class100*/kw basic-top-level-window% ()
		  [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
		   top-level-window%-keywords]
      (inherit on-traverse-char on-system-menu-char center)
      (sequence
	(let ([cwho '(constructor dialog)])
	  (check-label-string cwho label)
	  (check-top-level-parent/false cwho parent)
	  (for-each (lambda (x) (check-dimension cwho x)) (list width height x y))
	  (check-style cwho #f '(no-caption resize-border no-sheet close-button) style)))
      (rename [super-on-subwindow-char on-subwindow-char])
      (private-field [wx #f])
      (public
        [show-without-yield (lambda () 
                              (as-entry
                               (lambda ()
                                 (send wx call-show #t (lambda () (send wx show-without-yield))))))])
      (override
	[on-subwindow-char (lambda (w event)
			     (super-on-subwindow-char w event)
			     (or (on-system-menu-char event)
				 (on-traverse-char event)))])
      (sequence
	(as-entry
	 (lambda ()
	   (super-init (lambda (finish) 
			 (set! wx (finish (make-object wx-dialog% this this
						       (and parent (mred->wx parent)) label
						       (or x -11111) (or y -11111) (or width 0) (or height 0)
						       style)
					  #f))
			 wx)
		       (lambda () 
			 (let ([cwho '(constructor dialog)])
			   (check-container-ready cwho parent)))
		       label parent))))))
  
  (define (get-top-level-windows)
    (remq root-menu-frame (map wx->mred (wx:get-top-level-windows))))

  (define (get-top-level-focus-window)
    (ormap (lambda (f) (and (send f is-act-on?) 
			    (let ([f (wx->mred f)])
			      (and f
				   (not (eq? f root-menu-frame))
				   f))))
	   (wx:get-top-level-windows)))

  (define (get-top-level-edit-target-window)
    (let loop ([l (wx:get-top-level-windows)][f #f][s 0][ms 0])
      (if (null? l)
	  f
	  (let* ([f2 (car l)]
		 [f2m (wx->mred f2)]
		 [s2 (send f2 get-act-date/seconds)]
		 [ms2 (send f2 get-act-date/milliseconds)])
	    (if (and (or (not f)
			 (> s2 s)
			 (and (= s2 s) (> ms2 ms)))
		     (not (eq? f2m root-menu-frame)))
		(loop (cdr l) f2m s2 ms2)
		(loop (cdr l) f s ms))))))

  (define (send-message-to-window x y m)
    (check-slider-integer 'send-message-to-window x)
    (check-slider-integer 'send-message-to-window y)
    (let ([w (wx:location->window x y)])
      (and w (let ([f (wx->proxy w)])
	       (and f 
		    (not (eq? f root-menu-frame))
		    (send f on-message m))))))

  (define (check-top-level-parent/false who p)
    (unless (or (not p) (is-a? p frame%) (is-a? p dialog%))
      (raise-type-error (who->name who) "frame% or dialog% object or #f" p)))

  (define (check-frame-parent/false who p)
    (unless (or (not p) (is-a? p frame%))
      (raise-type-error (who->name who) "frame% object or #f" p)))

  (define root-menu-frame
    (and (current-eventspace-has-menu-root?)
         ;; The very first frame shown is somehow sticky under Cocoa,
         ;;  so create the root frame, show it , and hide it.
         (let* ([f (make-object (class frame%
                                  (define/override (on-exit)
                                    (exit))
                                  (super-make-object "Root" #f 0 0 -9000 -9000
                                                     '(no-resize-border no-caption))))]
                [wx (mred->wx f)])
           (set-root-menu-wx-frame! wx)
           (send wx designate-root-frame)
           f))))