;;;;
;;;; widget.stk                                 -- GTK widget
;;;;
;;;; Copyright © 2001-2022 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 30-May-2001 18:30 (eg)
;;;;


;;;;
;;;; GTK Bindings
;;;;
(define-gtk gtk-widget-destroy    (#:pointer) #:void    "gtk_widget_destroy")
(define-gtk gtk-widget-show       (#:pointer) #:void    "gtk_widget_show")
(define-gtk gtk-widget-show-all   (#:pointer) #:void    "gtk_widget_show_all")
(define-gtk gtk-widget-get-parent (#:pointer) #:pointer "gtk_widget_get_parent")

(define-gtk gtk-widget-set-tooltip-markup (#:pointer #:string) #:void
  "gtk_widget_set_tooltip_markup")

(define-gtk gtk-widget-get-allocated-width (#:pointer) #:long
  "gtk_widget_get_allocated_width")

(define-gtk gtk-widget-get-allocated-height (#:pointer) #:long
  "gtk_widget_get_allocated_height")

(define-gtk gtk-widget-set-size-request (#:pointer #:int #:int) #:void
  "gtk_widget_set_size_request")

(define-generic realize-widget)
(define-generic internal-arrange-widget)

;;;; ======================================================================
;;;;
;;;;    <gtk-object> class ...
;;;;
;;;; ======================================================================
(define-class <gtk-object> ()
  ()
  #:metaclass <gtk-virtual-slots-metaclass>)


;;;; ======================================================================
;;;;
;;;;    <destroyed-object> class ...
;;;;
;;;; ======================================================================
(define-class <destroyed-object> () ())


;;;; ======================================================================
;;;;
;;;;    <gtk-widget> class ...
;;;;
;;;; ======================================================================
(define (%widget-data-get widget key default)
  (key-get (slot-ref widget '%data) key default))

(define (%widget-data-set! widget key value)
  (let ((data (slot-ref widget '%data)))
    (slot-set! widget
               '%data
               (key-set! data key value))))


;;
;; width an height get & set
;;
(define (get-widget-width o)  (gtk-widget-get-allocated-width  (slot-ref o 'wid)))  ;; FIXME (%gtk-get-width  (slot-ref o 'wid)))
(define (get-widget-height o) (gtk-widget-get-allocated-height (slot-ref o 'wid)))      ;; FIXME(%gtk-get-height (slot-ref o 'wid)))

(define (set-widget-width! o v)
  (let ((h (slot-ref o 'height-request)))
    (gtk-widget-set-size-request (slot-ref o 'wid) v h)))

(define (set-widget-height! o v)
  (let ((w (slot-ref o 'width-request)))
    (gtk-widget-set-size-request (slot-ref o 'wid) w v)))



(define-class <gtk-widget> (<gtk-object>)
  ((wid         #:getter         wid)            ;; Widget Id
   (%event      #:init-form      '())            ;; Private event handler
   (%data       #:init-form      '())            ;; Private data
   (show        #:init-form      #t
                #:init-keyword   #:show)
   (parent      #:accessor       parent
                #:init-keyword   #:parent
                #:allocation     #:virtual
                #:slot-ref       (lambda (o)
                                   (let ((p (gtk-widget-get-parent (slot-ref o 'wid))))
                                     (if (eq? p #void) #f (diw p))))
                #:slot-set!      (lambda (o v)
                                   ;;// PROBLEM
                                   (if (pair? v)
                                       (apply container-add! (car v) o (cdr v))
                                       (container-add! v o))))
   (can-default #:accessor       can-default
                #:init-keyword   #:can-default
                #:allocation     #:gtk-property)
   (can-focus   #:accessor       can-focus
                #:init-keyword   #:can-focus
                #:allocation     #:gtk-property)
   (has-default #:accessor       has-default
                #:init-keyword   #:has-default
                #:allocation     #:gtk-property)
   (has-focus   #:accessor       has-focus
                #:init-keyword   #:has-focus
                #:allocation     #:gtk-property)
   (height-request
                #:accessor       height-request
                #:init-keyword   #:height-request
                #:allocation     #:gtk-property)
   (name        #:accessor       name
                #:init-keyword  #:name
                #:allocation    #:gtk-property)
   (visible     #:accessor      visible
                #:init-keyword  #:visible
                #:allocation    #:gtk-property)
   (sensitive   #:accessor      sensitive
                #:init-keyword  #:sensitive
                #:allocation    #:gtk-property)
   (width-request
                #:accessor     width-request
                #:init-keyword #:width-request
                #:allocation   #:gtk-property)
   (tooltip     #:accessor     tooltip
                #:init-keyword #:tooltip
                #:allocation   #:virtual
                #:slot-ref     (lambda (o)
                                 ;; Since the string returned by gtk-widget-get-tooltip-markup
                                 ;; must be freed. We store the tooltip as a Scheme string.
                                 (key-get (slot-ref o '%data) #:tooltip #f))
                :slot-set!     (lambda (o v)
                                 (gtk-widget-set-tooltip-markup (slot-ref o 'wid) v)
                                 (slot-set! o '%data
                                            (key-set!  (slot-ref o '%data) #:tooltip v))))
   (width       #:accessor     width
                #:init-keyword #:width
                #:allocation   #:virtual
                #:slot-ref     get-widget-width
                #:slot-set!    set-widget-width!)
   (height      #:accessor     height
                #:init-keyword #:height
                #:allocation   #:virtual
                #:slot-ref     get-widget-height
                #:slot-set!    set-widget-height!)

#;   (font-name #:accessor       font-name
                #:init-keyword   #:font-name
                #:allocation     #:gtk-property
                #:gtk-name       "gtk-font-name")

;;//   (event   #:accessor       event
;;//            #:init-keyword   #:event
;;//            #:allocation     #:virtual
;;//            #:slot-ref       (lambda (o)
;;//                              (slot-ref o '%event))
;;//            #:slot-set!      (lambda (o v)
;;//                              (let ((old-event (slot-ref o '%event)))
;;//                                (when old-event
;;//                                  (disconnect-event-handler! old-event o))
;;//                                (connect-event-handler! v o)
;;//                                (slot-set! o '%event v))))
;;//   (widget-data #:accessor     widget-data
;;//            #:init-keyword #:widget-data
;;//            #:init-form    #f)

;;              #:allocation   #:virtual ;; to ensure that can-default is #t
;;//            #:slot-ref     (lambda (o)
;;//                            (%gtk-arg-get (slot-ref o 'wid) #:has_default))
;;//            #:slot-set!    (lambda (o v)
;;//                            (unless (slot-ref o 'can-default)
;;//                              ;; Force can-default to avoid GTK warning
;;//                              (slot-set! o 'can-default #t))
;;//                            (update)
;;//                            (%gtk-arg-set! (slot-ref o 'wid) #:has_default v)
;;//                            (update)))
   ))

;======================================================================
;
;                       Methods for Widgets
;
;======================================================================
(define-method realize-widget ((self <gtk-widget>) initargs)
  ;; Do nothing
  #f)

(define-method internal-arrange-widget ((self <gtk-widget>) initargs)
  ;; Do nothing
  #f)


(define-method initialize-instance ((self <gtk-widget>) initargs)
  ;; Initialize %data slot as soon as possible
  (slot-set! self '%data '())
  (realize-widget self initargs)
  ;;(eprintf "NEXT sur ~S\n" self)
  (next-method self initargs)
  ;;(eprintf "retour NEXT sur ~S\n" self)
  (internal-arrange-widget self initargs)
  (let ((wid (slot-ref self 'wid)))
    ;; Show object (eventually)
    (when (slot-ref self 'show)
      (gtk-widget-show wid))
    ;; Store self in GTk+ object to allow GTK <-> Scheme conversions
    (gtklos-wid-associate wid self)))


;;;
;;; Destroy
;;;
(define-method destroy ((w <gtk-widget>))
;;//  (let ((event (slot-ref w '%event)))               ; Disconnect w from its  handler
;;//    (when event
;;//      (disconnect-event-handler! event w)))
  (gtk-widget-destroy (wid w))                  ; destroy the GTK widget
  (change-class w <destroyed-object>))          ; Change class to <destroyed-object>


(define-method destroy (w)
  #f)


;;//(define-method widget-width ((w <gtk-widget>))
;;//  (gtk-widget-get-allocated-width  (slot-ref w 'wid)))
;;//
;;//(define-method widget-height ((w <gtk-widget>))
;;//  (gtk-widget-get-allocated-height (slot-ref w 'wid)))


;;;
;;; Event connection
;;;
(define-method event-connect ((widget <gtk-object>) name closure)
  (g-signal-connect (slot-ref widget 'wid)
                    name
                    (scheme-proc->gtk-handler closure widget)
                    (void)))

(define-method event-connect-after ((widget <gtk-object>) name closure)
  (g-signal-connect-after  (slot-ref widget 'wid)
                           name
                           (scheme-proc->gtk-handler closure)
                           (void)))



;;;; ======================================================================
;;;;
;;;;    <gtk-misc> class ...
;;;;
;;;; ======================================================================
 (define-class <gtk-misc> (<gtk-widget>)
   ((xalign      #:accessor     xalign
                 #:init-keyword #:xalign
                 #:allocation   #:gtk-property)
    (yalign      #:accessor     yalign
                 #:init-keyword #:yalign
                 #:allocation   #:gtk-property)
    (xpad        #:accessor     xpad
                 #:init-keyword #:xpad
                 #:allocation   #:gtk-property)
    (ypad        #:accessor     ypad
                 #:init-keyword #:ypad
                 #:allocation   #:gtk-property)))



;;;; ======================================================================
;;;;
;;;;    <gtk-orientable> class ...
;;;;
;;;; ======================================================================
(define (orientation->int orient)
  (case orient
    ((horizontal) 0)
    ((vertical)   1)
    (else (error "bad orientation value: ~S\n" orient))))

(define (int->orientation orient)
  (if (zero? orient) 'horizontal 'vertical))

(define-class <gtk-orientable> (<gtk-widget>)
  ((orientation    #:accessor       orientation
                   #:init-keyword   #:orientation
                   #:allocation     #:virtual
                   #:slot-ref       (lambda (o)
                                      (int->orientation
                                       (gtk-orientable-get-orientation
                                        (slot-ref o 'wid))))
                   #:slot-set!      (lambda (o v)
                                      (let ((v (orientation->int v)))
                                        (gtk-orientable-set-orientation
                                         (slot-ref o 'wid) v))))))

;;;
;;; Module exports
;;;
(export  realize-widget internal-arrange-widget
         ;; accessors
         parent can-default has-default has-focus height-request name visible
         sensitive width-request tooltip xalign yalign xpad ypad
         ;; methods
         destroy event-connect event-connect-after
         get-widget-width get-widget-height)
