;; Copyright (c) 2004 James Bailey (dgym.REMOVE_THIS.bailey@gmail.com).
;;
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"), to
;; deal in the Software without restriction, including without limitation the
;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in all
;; copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;; gtk-glade - this module exports glade-parse, which takes an xmls representation
;; of a glade save file, and generates all the widgets based on that information.
;; returns a hashtable of widget-ids (strings) to widget instances

(defpackage :gtk-glade
  (:use :common-lisp :gtk)
  (:export
    glade-parse))
(in-package :gtk-glade)

(defun get-attr (node name &optional (default ""))
  (let ((pair (assoc name (xmls:node-attrs node) :test #'string=)))
    (if pair
      (second pair)
      default)))

(defun get-props (node)
  (loop with res = (make-hash-table :test 'equal)
        for child in (get-children node "property")
        finally return res
        do
        (setf (gethash (get-attr child "name" "") res)
              (first (xmls:node-children child)))))

(defun get-int-prop (hash name)
  (parse-integer (gethash name hash "0")))

(defun get-bool-prop (hash name &optional (default nil))
  (string= (gethash name hash (if default "True" "False")) "True"))

(defun get-bool-prop-i (hash name &optional (default nil))
  (if (get-bool-prop hash name default)
    1
    0))

(defun get-children (node name)
  (remove-if (lambda (x) (not (and (consp x) (string= (car x) name))))
             (xmls:node-children node)))

(defun add-widget (child parent clas-hier node-hier)
  ;;(pprint clas-hier)
  (macrolet ((with-packing-props 
               (&body body)

               `(let ((props (get-props (first (get-children (second node-hier) "packing")))))
                  ,@body)))

    (case (first clas-hier)
      (|GtkTable|
        (let ((props (get-props (first (get-children (second node-hier) "packing")))))
          (gtk_table_attach_defaults parent child 
                                     (get-int-prop props "left_attach")
                                     (get-int-prop props "right_attach")
                                     (get-int-prop props "top_attach")
                                     (get-int-prop props "bottom_attach"))))
      ((|GtkVBox| |GtkHBox|)
       (with-packing-props
         (gtk_box_pack_start parent
                             child
                             (get-bool-prop-i props "expand")
                             (get-bool-prop-i props "fill")
                             (get-int-prop props "padding"))))

      (|GtkMenuItem|
        (gtk_menu_item_set_submenu parent child))

      (|GtkNotebook|
        (let ((cont (g_object_get_data parent "__child_store")))
          (cond 
            (cont
              (gtk_notebook_append_page parent cont child)
              (g_object_set_data parent "__child_store" nil))
            (t
              (g_object_set_data parent "__child_store" child)))))
      
      (otherwise
        (gtk_container_add parent child)))))

(defun glade-parse (node &optional (parent nil) (clas-hier nil) (node-hier nil) (id-map (make-hash-table :test 'equal)))
  (let ((clas nil)
        (props nil)
        (new-widget nil))
    (when (consp node)

      (when (string= (xmls:node-name node) "widget")
        (setq clas (intern (get-attr node "class" "") :gtk-glade))
        (setq props (get-props node))

        (case clas
          (|GtkWindow|
            (setq new-widget (gtk_window_new 0))
            (gtk_window_set_title new-widget (gethash "title" props ""))
            (gtk_window_set_default_size 
              new-widget 
              (get-int-prop props "default_width")
              (get-int-prop props "default_height")))
          (|GtkVBox|
            (setq new-widget (gtk_vbox_new (get-bool-prop-i props "homogeneous")
                                           (length (get-children node "child")))))
          (|GtkHBox|
            (setq new-widget (gtk_hbox_new (get-bool-prop-i props "homogeneous")
                                           (length (get-children node "child")))))
          (|GtkTable|
            (setq new-widget (gtk_table_new 0
                                            (parse-integer (gethash "n_rows" props))
                                            (parse-integer (gethash "n_columns" props)))))
          (|GtkScrolledWindow|
            (setq new-widget (gtk_scrolled_window_new nil nil)))
          
          (|GtkLabel|
            (setq new-widget (gtk_label_new (gethash "label" props ""))))
          (|GtkButton|
            (setq new-widget (gtk_button_new_with_label (gethash "label" props ""))))
          (|GtkEntry|
            (setq new-widget (gtk_entry_new)))
          (|GtkTreeView|
            (setq new-widget (gtk_tree_view_new))
            (gtk_tree_view_set_headers_visible new-widget 
                                               (get-bool-prop-i props "headers_visible")))
          
          (|GtkMenuBar|
            (setq new-widget (gtk_menu_bar_new)))
          (|GtkMenu|
            (setq new-widget (gtk_menu_new)))
          (|GtkMenuItem|
            (let ((label (gethash "label" props nil)))
              (setq new-widget 
                    (if label
                      (gtk_menu_item_new_with_mnemonic label)
                      (gtk_menu_item_new)))))

          (|GtkNotebook|
            (setq new-widget (gtk_notebook_new)))

          (otherwise
            (format t "unhandled widget : ~a~%" clas))))

      (when new-widget
        (setq new-widget new-widget)

        (when parent
          (add-widget new-widget parent clas-hier (cons node node-hier)))

        (setf (gethash (get-attr node "id" "") id-map)
              new-widget)
        (setf (gethash new-widget id-map)
              (get-attr node "id" ""))

        ;; set up signals
        (loop for signal in (get-children node "signal") do
              (gtk_connect new-widget 
                           (get-attr signal "name") 
                           (let ((code (read-from-string (get-attr signal "handler"))))
                             (lambda (&rest args) (eval code))))))

      (loop with clases = (if clas 
                            (cons clas clas-hier)
                            clas-hier)
            with nodes = (cons node node-hier)
            for child in (xmls:node-children node) do
            (glade-parse child (or new-widget parent) clases nodes id-map))

      id-map)))