;;;;
;;;; menu.stk           -- GTK+ Menu Management
;;;;
;;;; Copyright © 2000-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: 27-Oct-2000 22:09 (eg)
;;;;

;;;
;;; GTK bindings
;;;
(define-gtk gtk-menu-bar-new ()  #:pointer "gtk_menu_bar_new")
(define-gtk gtk-menu-new ()      #:pointer "gtk_menu_new")
(define-gtk gtk-menu-item-new () #:pointer "gtk_menu_item_new")

(define-gtk gtk-menu-item-set-submenu (#:pointer #:pointer) #:void
  "gtk_menu_item_set_submenu")

(define-gtk gtk-check-menu-item-new () #:pointer "gtk_check_menu_item_new")

 (define-gtk gtk-radio-menu-item-new (#:pointer) #:pointer
  "gtk_radio_menu_item_new")
 (define-gtk gtk-radio-menu-item-new-from-widget (#:pointer) #:pointer
   "gtk_radio_menu_item_new_from_widget")

(define-gtk gtk-separator-menu-item-new () #:pointer "gtk_separator_menu_item_new")

;;######################################################################
;;
;;           Menu & Menubars  stuff
;;
;;######################################################################
;;
;; Hiereachy
;; <gtk-menu-shell>  (a container)
;;    <menu-bar>
;;    <menu>
(define-class <gtk-menu-shell> (<gtk-container>)
  ())

;;======================================================================
;;
;;           < m e n u - b a r >
;;
;;======================================================================
(define-class <menu-bar> (<gtk-menu-shell>)
  ())

(define-method realize-widget ((self <menu-bar>) initargs)
  (let ((mb (gtk-menu-bar-new)))
    (cpointer-type-set! mb 'gtk-menu-bar)
    (slot-set! self 'wid mb)))


;;======================================================================
;;
;;           < m e n u >
;;
;;======================================================================
(define-class <menu> (<gtk-menu-shell>)
  ((active              #:accessor       active
                        #:init-keyword   #:active
                        #:allocation     #:gtk-property)
   (reserve-toggle-size #:accessor       reserve-toggle-size
                        #:init-keyword   #:reserve-toggle-size
                        #:allocation     #:gtk-property)
   (tearoff-state       #:accessor       tearoff-state
                        #:init-keyword   #:tearoff-state
                        #:allocation     #:gtk-property)
   (tearoff-title       #:accessor       tearoff-title
                        #:init-keyword   #:tearoff-title
                        #:allocation     #:gtk-property)))


(define-method realize-widget ((self <menu>) initargs)
  (let ((m (gtk-menu-new)))
    (cpointer-type-set! m 'gtk-menu)
    (slot-set! self 'wid m)))



;;######################################################################
;;
;;           Menu Items stuff
;;
;;######################################################################
;;; Menu Items Hierarchy
;;; <gtk-menu-item>
;;;     <menu-item>
;;;         <menu-check-item>
;;;         <menu-radio-item>
;;;     <menu-separator-item>
;;;         <menu-tear-off-item>


(define-class <gtk-menu-item> (<gtk-container>)
  ((command     #:accessor      command
                #:init-keyword  #:command
                #:allocation    #:virtual
                #:slot-ref      (%make-event-getter-func "activate")
                #:slot-set!     (%make-event-setter-func "activate"))))

;;======================================================================
;;
;;           < m e n u - i t e m >
;;
;;======================================================================
(define-class <menu-item> (<gtk-menu-item>)
  ((text            #:accessor      text
                    #:init-keyword  #:text
                    #:allocation    #:gtk-property
                    #:gtk-name      "label")
   (right-justified #:accessor      right-justified
                    #:init-keyword  #:right-justified
                    #:allocation    #:gtk-property)
   (accel-path      #:accessor      accel-path
                    #:init-keyword  #:accel-path
                    #:allocation    #:gtk-property)
   (use-underline   #:accessor      use-underline
                    #:init-keyword  #:use-underline
                    #:allocation    #:gtk-property)))

(define-method realize-widget ((self <menu-item>) initargs)
  (let ((mi (gtk-menu-item-new)))
    (cpointer-type-set! mi 'gtk-menu-item)
    (slot-set! self 'wid mi)))

;;======================================================================
;;
;;           < m e n u - c h e c k - i t e m >
;;
;;======================================================================
(define-class <menu-check-item> (<menu-item>)
  ((value         #:accessor      value
                  #:init-keyword  #:value
                  #:allocation    #:gtk-property
                  #:gtk-name      "active")
   (draw-as-radio #:accessor      draw-as-radio
                  #:init-keyword  #:draw-as-radio
                  #:allocation    #:gtk-property)
   (inconsistent  #:accessor      inconsistent
                  #:init-keyword  #:inconsistent
                  #:allocation    #:gtk-property)))

(define-method realize-widget ((self <menu-check-item>) initargs)
  (let ((mi (gtk-check-menu-item-new)))
    (cpointer-type-set! mi 'gtk-check-menu-item)
    (slot-set! self 'wid mi)))

;======================================================================
;
;           < m e n u - r a d i o - i t e m >
;
;======================================================================
(define-class <menu-radio-item> (<menu-check-item>)
  ((sibling #:getter     sibling
            #:allocation #:virtual
            #:slot-ref   (lambda (o) (%widget-data-get o #:sibling #f))
            #:slot-set!  (gtklos-slot-is-ro 'sibling))))


(define-method realize-widget ((self <menu-radio-item>) initargs)
  (let* ((sibling (key-get initargs #:sibling #f))
         (id      (if sibling
                      (gtk-radio-menu-item-new-from-widget (wid sibling))
                      (gtk-radio-menu-item-new (void)))))
    (cpointer-type-set! id 'gtk-radio-menu-item)
    (slot-set! self 'wid id)))


(define-method initialize-instance ((self <menu-radio-item>) initargs)
  (next-method)
  (let ((sibling (key-get initargs #:sibling #f)))
    (when sibling
      (%widget-data-set! self #:sibling sibling))))


;======================================================================
;
;           < m e n u - s e p a r a t o r - i t e m >
;
;======================================================================
(define-class <menu-separator-item> (<gtk-menu-item>)
  ())

(define-method realize-widget ((self <menu-separator-item>) initargs)
  (let ((mi (gtk-separator-menu-item-new)))
    (cpointer-type-set! mi 'gtk-separator-menu-item)
    (slot-set! self 'wid mi)))

;;======================================================================
;;
;; Utility function to fill a menubar
;;
;;======================================================================
(define-method add-items-to-menubar ((mb <menu-bar>) items)

  (define (fill-menu m items)
    (let ((sibling #f))
      (for-each (lambda (x)
                  (let ((title  (car x))
                        (action (key-get (cdr x) #:action #f))
                        (type   (key-get (cdr x) #:type   #:item)))
                    (case type
                      ((#:separator)
                       (make <menu-separator-item> #:parent m))
                      ((#:item)
                       (make <menu-item> #:text title #:parent m #:command action))
                      ((#:check)
                       (let ((val (key-get (cdr x) #:value #f)))
                         (make <menu-check-item> #:text title #:parent m #:value val
                               #:command action)))
                      ((#:radio)
                       (let* ((first (key-get (cdr x) #:first #f))
                              (group (if first #f sibling))
                              (val   (key-get (cdr x) #:value #f)))
                         (set! sibling
                               (make <menu-radio-item> #:text title #:parent m
                                     #:sibling group #:value val #:command action))))
                      ((#:cascade)
                       (let* ((new (make <menu-item> #:text title #:parent m))
                              (sub (make <menu> #:parent new)))
                         (fill-menu sub (key-get (cdr x) #:menu '()))))
                      )))
                items)))
  ;;
  ;; add-menubar-items starts here
  ;;
  (let ((right #f))
    (for-each (lambda (x)
                (if (null? x)
                    (set! right #t)
                    (let* ((mi (make <menu-item> #:text (car x)
                                                 #:parent mb
                                                 #:right-justified right))
                           (m  (make <menu> #:parent mi)))
                      ;; Fill menu with the given items
                      (fill-menu m (cdr x)))))
              items)))


(define-method container-add! ((self <menu-item>) (child <menu>) . opts)
  (gtk-menu-item-set-submenu (slot-ref self 'wid)
                             (slot-ref child 'wid)))

;;(define-method add-menu-item! ((bar <gtk-menu-shell>) (x <menu-item>))
;;  (gtk-menu-shell-append (slot-ref bar 'wid) (slot-ref x 'wid)))

;;;
;;; Exports
;;;
(export <menu-bar>
        <menu> active reserve-toggle-size tearoff-state tearoff-title
        <menu-item> right-justified accel-path use-underline
        <menu-check-item> value draw-as-radio inconsistent
        <menu-separator-item>
        add-items-to-menubar)

