(in-package :smoke)

(defun constant-definition (package method smoke)
  "Returns an expression that defines a constant for the enum METHOD.
The second return value is the expression to export the constant."
  (let ((symbol 
         (if (or (string= (name (get-class method))
                          "Qt")
                 (string= (name (get-class method))
                          "QGlobalSpace"))
             (lispify (concatenate 'string "+" (name method)
                                   "+")
                      package)
             (lispify (concatenate 'string
                                   (name (get-class method))
                                   ".+"
                                   (name method) "+")
                      package))))
    (values
     (if (= 8 (type-id (return-type method)))
         `(define-constant ,symbol ;; a long, not really an enum.
              ,(enum-call method))
         `(define-constant ,symbol
              (make-instance 'enum
                             :value ,(enum-call method)
                             :type (make-instance 'smoke-type
                                                  :id ,(id (return-type method))
                                                  :smoke ,smoke))
            :test #'enum=))
     symbol)))

(defun static-method-symbol (package method)
  "Returns the lisp symbol for the static method METHOD."
  (let ((class (get-class method)))
    (lispify (concatenate 'string
                          (if (string= (name class)
                                       "QGlobalSpace")
                              nil
                              (concatenate 'string
                                           (name class)
                                           "."))
                          (name method))
			  package)))

(defun static-method-definition (package method &optional (argument-count -1))
  "Returns an expression to define a function for the static METHOD.
The second return value is the expression to export the function."
  (let* ((class (get-class method))
         (method-name (name method))
         (name (static-method-symbol package method)))
    (values
     `(defun ,name ,(if (< argument-count 0)
                        '(&rest args)
                        (make-lambda argument-count))
        (call-using-args
         (find-class (quote ,(lispify (name class) 
                                      (if (string= (name class)
                                                   "QGlobalSpace")
                                          *package* ;; See #'MAKE-SMOKE-CLASSES
                                          package))))
         ,method-name
         ,(if (< argument-count 0)
              'args
              `(list ,@(make-lambda argument-count)))))
     name)))

(defun ensure-generic-methods (symbols-names)
  "Ensures the generic functions for SYMBOLS-NAMES."
  (declare (list symbols-names)
           (optimize (speed 3)))
  (dolist (symbol-name symbols-names)
    (ensure-generic-function (first symbol-name)
                             :cxx-name (rest symbol-name)
                             :generic-function-class 'smoke-gf
                             :lambda-list '(object &rest args))
    (export (first symbol-name) :cxx)))

(defun setf-method-definition (method)
  `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
     (,(lispify (name method) :cxx) object new-value)
     new-value))

(defmacro sizes= ((smoke)&rest arrays)
  `(and ,@(loop for array in arrays collect
               `(= (smoke-array-length (,array ,smoke))
                   ,(smoke-array-length (funcall (fdefinition array)
                                                 (eval smoke)))))))

(defmacro check-recompile (smoke)
  "Raises an error or tries to recompile when the fasl of the define-classes-and-gfs
was not compiled against the current smoke module."
  (with-unique-names (restart)
    `(eval-when (:load-toplevel :execute)
       (unless (sizes= (,smoke)
                       smoke-module-methods
                       smoke-module-method-names
                       smoke-module-method-maps
                       smoke-module-classes
                       smoke-module-types)
         (let ((,restart (find-restart 'asdf:try-recompiling)))
           (if ,restart
               (invoke-restart ,restart)
               (error "The smoke module ~A changed, you need to recompile the lisp file."
                      (smoke-get-module-name (smoke-module-pointer ,smoke)))))))))

(defmacro define-classes-and-gfs (package smoke)
  "Process the C++ methods of the Smoke module SMOKE.
Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods
and a function do define the generic methods a load-time."
;;; symbol - id pairs are stored in the hash-tables to prevent the
;;; multiple definition of a function with the same name.
  (let ((generics (make-hash-table))
        (constants)
        (functions)
        (function-symbols (make-hash-table))
        (setf-function-symbols (make-hash-table))
        (exports))
    (map-methods 
     #'(lambda (method)
         (when (and (enum-p method)
                    ;; qt.network has QIODevice::NotOpen(), but the
                    ;; class is external (workaround).
                    (not (external-p (get-class method))))
           (multiple-value-bind (def export) (constant-definition package method smoke)
             (push def
                   constants)
             (push export exports)))
         (when (and (not (destructor-p method))
                    (not (constructor-p method))
                    (not (enum-p method))
                    (not (eql nil (name method)))
                    (string/= (name method) "tr")) ;; we have a custom qt:tr function
           (let ((name (name method)))
             (when (and (starts-with-subseq "set" name)
                        (> (length name) 3)
                        (upper-case-p (char name 3))
                        (= 1 (get-arguments-length method)))
               (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))
                 (setf (gethash (lispify name :cxx) setf-function-symbols) t)
                 (push (setf-method-definition method) functions)))
             (let ((lisp-name (lispify name "CXX")))
               (unless (and (gethash lisp-name generics) (attribute-p method))
                 (setf (gethash lisp-name generics) name))))
           (when (static-p method)
             (let* ((function-symbol (static-method-symbol package method))
                    (methods (gethash function-symbol function-symbols)))
               (unless (fboundp function-symbol) ;; do not overwrite
                 ;; existing functions e.g. qInstallMsgHandler of
                 ;; qt.core with that of qt.gui which causes a
                 ;; segfault when loading from an saved image.
                 (setf (gethash function-symbol function-symbols)
                       (if methods (- (id method)) (id method))))))))
     (eval smoke))
    (loop for id being the hash-values of function-symbols do
         (let ((method (make-smoke-method
                        :smoke (eval smoke)
                        :id (abs id))))
           (multiple-value-bind (definition export)
               (static-method-definition
	       	package
                method
                (if (< 0 id)
                    (get-arguments-length method)
                    -1))
             (push definition functions)
             (push export exports))))
    `(progn (check-recompile ,smoke)
            ,@functions
            (eval-startup (:compile-toplevel :load-toplevel :execute)
              ;; FIXME when loading the Lisp image we no longer need
              ;; to call #'ensure-class, but the class-map needs still
              ;; to be populated by #'add-id-class-map and #'add-id;
              ;; For now we ignore the negligible overhead.
              (make-smoke-classes ,package ,smoke))
            (eval-when (:load-toplevel :execute)
              (ensure-generic-methods ',(hash-table-alist generics)))
            ,@constants
            (eval-when (:load-toplevel :execute)
              (export (quote ,exports) ,package)))))