(module mrwindow racket/base
  (require racket/class
           (prefix-in wx: "kernel.rkt")
           "lock.rkt"
           "helper.rkt"
           "const.rkt"
           "check.rkt"
           "wx.rkt"
           "wxwindow.rkt"
           "mrpopup.rkt")

  (provide area<%>
           area%
           (protect-out internal-subarea<%>)
           subarea<%>
           (protect-out make-subarea%)
           window<%>
           subwindow<%>
           (protect-out make-window%)
           
           (protect-out set-get-outer-panel
                        set-parent))

  (define area<%>
    (interface ()
      get-parent get-top-level-window
      min-width min-height
      get-graphical-min-size
      stretchable-width stretchable-height))

  (define-local-member-name
    set-get-outer-panel
    set-parent)

  (define area%
    (class* mred% (area<%>)
      (init mk-wx get-wx-pan get-outer-wx-pan mismatches prnt
            ;; for keyword use:
            [min-width no-val]
            [min-height no-val]
            [stretchable-width no-val]
            [stretchable-height no-val])
      (let ([cwho '(iconstructor area)])
        (unless (eq? min-width no-val) (check-init-dimension cwho min-width))
        (unless (eq? min-height no-val) (check-init-dimension cwho min-height)))
      (mismatches)
      (define get-wx-outer-panel get-outer-wx-pan)
      (define parent prnt)
      (public [minw min-width]
              [minh min-height]
              [sw stretchable-width]
              [sh stretchable-height])
      (define minw (param get-wx-outer-panel min-width))
      (define minh (param get-wx-outer-panel min-height))
      (define sw (param get-wx-outer-panel stretchable-in-x))
      (define sh (param get-wx-outer-panel stretchable-in-y))
      (public*
       [set-parent (lambda (p) (set! parent p))] ; called in atomic mode
       [get-parent (lambda () parent)]
       [get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))]
       [get-graphical-min-size (entry-point (lambda () 
                                              (if (wx . is-a? . wx-basic-panel<%>)
                                                  (apply values (send wx get-graphical-min-size))
                                                  (send wx get-hard-minimum-size))))])
      (define wx (mk-wx))
      (super-make-object wx)
      (unless (eq? min-width no-val) (when min-width (minw min-width)))
      (unless (eq? min-height no-val) (when min-height (minh min-height)))
      (unless (eq? stretchable-width no-val) (sw stretchable-width))
      (unless (eq? stretchable-height no-val) (sh stretchable-height))))

  (define internal-subarea<%> (interface ()))

  (define subarea<%> 
    (interface (area<%> internal-subarea<%>)
      horiz-margin vert-margin))

  (define (make-subarea% %) ; % implements area<%>
    (class* % (subarea<%>)
      (init mk-wx get-wx-pan get-outer-wx-pan mismatches parent
            ;; for keyword use
            [horiz-margin no-val]
            [vert-margin no-val])
      (let ([cwho '(iconstructor subarea)])
        (unless (eq? horiz-margin no-val) (check-margin-integer cwho horiz-margin))
        (unless (eq? vert-margin no-val) (check-margin-integer cwho vert-margin)))
      (define get-wx-panel get-wx-pan)
      (define hm (param get-wx-panel x-margin))
      (define vm (param get-wx-panel y-margin))
      (public [hm horiz-margin]
              [vm vert-margin])
      (super-make-object mk-wx get-wx-panel get-outer-wx-pan mismatches parent)
      (unless (eq? horiz-margin no-val) (hm horiz-margin))
      (unless (eq? vert-margin no-val) (vm vert-margin))))

  (define window<%>
    (interface (area<%>)
      on-focus focus has-focus?
      on-size on-move
      accept-drop-files on-drop-file
      on-subwindow-char on-subwindow-event
      client->screen screen->client
      enable is-enabled? on-superwindow-enable
      get-label set-label get-plain-label
      get-client-size get-size get-width get-height get-x get-y
      get-cursor set-cursor popup-menu
      show is-shown? on-superwindow-show refresh
      warp-pointer
      get-handle get-client-handle))

  (define subwindow<%> 
    (interface (window<%> subarea<%>)
      reparent))

  (define (make-window% top? %) ; % implements area<%>
    (class* % (window<%>)
      (init mk-wx get-wx-panel get-outer-wx-panel mismatches lbl parent crsr
            ;; for keyword use
            [enabled #t])
      (define label lbl)
      (define cursor crsr)
      (public*
       [popup-menu (entry-point 
                    (lambda (m x y)
                      (check-instance '(method window<%> popup-menu) popup-menu% 'popup-menu% #f m)
                      (check-position '(method window<%> popup-menu) x)
                      (check-position '(method window<%> popup-menu) y)
                      (let ([mwx (mred->wx m)])
                        (and (send mwx popup-grab this)
                             (as-exit
                              (lambda ()
                                (send m on-demand)
                                (send wx popup-menu mwx x y)))))))]
       [on-focus (lambda (x) (void))]
       [on-subwindow-focus (lambda (win active?) (void))]
       [on-size (lambda (w h)
                  (check-dimension '(method window<%> on-size) w)
                  (check-dimension '(method window<%> on-size) h))]
       [on-move (lambda (x y)
                  (check-position '(method window<%> on-move) x)
                  (check-position '(method window<%> on-move) y))]
       [on-subwindow-char (lambda (w e)
                            (check-instance '(method window<%> on-subwindow-char) window<%> 'window<%> #f w)
                            (check-instance '(method window<%> on-subwindow-char) wx:key-event% 'key-event% #f e)
                            #f)]
       [on-subwindow-event (lambda (w e)
                             (check-instance '(method window<%> on-subwindow-event) window<%> 'window<%> #f w)
                             (check-instance '(method window<%> on-subwindow-event) wx:mouse-event% 'mouse-event% #f e)
                             #f)]
       [on-drop-file (lambda (s)
                       (unless (path-string? s)
                         (raise-argument-error (who->name '(method window<%> on-drop-file)) "path-string?" s)))]

       [focus (entry-point (lambda () (send wx set-focus)))]
       [has-focus? (entry-point (lambda () (send wx has-focus?)))]
       [enable (entry-point (lambda (on?) (send wx enable on?)))]
       [is-enabled? (entry-point (lambda () (send wx is-enabled?)))]
	
       [get-label (lambda () label)]
       [set-label (lambda (l)
                    (check-label-string/false '(method window<%> set-label) l)
                    (set! label (if (string? l)
                                    (string->immutable-string l)
                                    l)))]
       [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]

       [get-handle (lambda () (send wx get-handle))]
       [get-client-handle (lambda () (send wx get-client-handle))]

       [accept-drop-files
        (entry-point
         (case-lambda
	   [() (send wx accept-drag?)]
	   [(on?) (send wx drag-accept-files on?)]))]
	
       [client->screen (entry-point
                        (lambda (x y)
                          (check-position '(method window<%> client->screen) x)
                          (check-position '(method window<%> client->screen) y)
                          (double-boxed
                           x y
                           (lambda (x y) (send wx client-to-screen x y)))))]
       [screen->client (entry-point
                        (lambda (x y)
                          (check-position '(method window<%> screen->client) x)
                          (check-position '(method window<%> screen->client) y)
                          (double-boxed
                           x y
                           (lambda (x y) (send wx screen-to-client x y)))))]
       [get-client-size (entry-point
                         (lambda ()
                           (double-boxed
                            0 0
                            (lambda (x y) (send wx get-client-size x y)))))]
       [get-size (entry-point
                  (lambda ()
                    (double-boxed
                     0 0
                     (lambda (x y) (send wx get-size x y)))))]
	
       [get-width (entry-point (lambda () (send wx get-width)))]
       [get-height (entry-point (lambda () (send wx get-height)))]
       [get-x (entry-point (lambda () (- (send wx get-x) (if top? 0 (send (send wx get-parent) ext-dx)))))]
       [get-y (entry-point (lambda () (- (send wx get-y) (if top? 0 (send (send wx get-parent) ext-dy)))))]
	
       [get-cursor (lambda () cursor)]
       [set-cursor (entry-point
                    (lambda (x)
                      (unless (or (not x) (x . is-a? . wx:cursor%))
                        (raise-argument-error (who->name '(method window<%> set-cursor))
                                              "(or/c (is-a?/c cursor%) #f)"
                                              x))
                      (send wx set-cursor x)
                      (set! cursor x)))]

       [show (entry-point (lambda (on?) 
                            (when on?
                              (unless top?
                                (unless (memq wx (send (send wx area-parent) get-children))
                                  (raise-arguments-error 
                                   (who->name '(method window<%> show))
                                   "cannot show a subwindow that is not active in its parent"
                                   "subwindow" this))))
                            (send wx show on?)))]
       [is-shown? (entry-point (lambda () (send wx is-shown?)))]
       [on-superwindow-show (lambda (visible?) (void))]
       [on-superwindow-enable (lambda (active?) (void))]

       [refresh (entry-point (lambda () (send wx refresh)))]
       
       [warp-pointer (entry-point (lambda (x y) 
                                    (let ([who '(method window<%> warp-pointer)])
                                      (check-init-position who x)
                                      (check-init-position who y))
                                    (send wx warp-pointer x y)))])
      (define wx #f)
      (super-make-object (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent)
      (unless enabled (enable #f)))))