(in-package :cl-smoke.qt.core)

;; Smoke always calls the method of the class the object is assumed to
;; be and not the most specific method like required for virtual
;; methods. Thus we implement a virtual metaObject() method to
;; determine the actual class. This is only needed for objects not
;; constructed by Smoke, since otherwise we would know the most
;; specific class.
(defcfun cl-smoke-meta-object :pointer (object :pointer))
(defun meta-object (object)
  (make-instance 'qt:meta-object
                 :pointer (cl-smoke-meta-object (pointer object))))

(defmethod cxx:static-meta-object ((class cxx:class))
  (cxx:static-meta-object (smoke::find-smoke-class class)))

(defmethod documentation :around ((class smoke::smoke-standard-class)
                                  (doc-type (eql 't)))
  (if (and (subtypep class (find-class 'qt:object))
           (not (subtypep class (find-class 'cxx:class))))
      (format nil "~@[~A~%~]Properties:~%~T~{~<~%~T~0,75:; ~(~A~)~>~}

Signals:
~{~T~A~%~}
Slots:
~{~T~A~%~}"
              (call-next-method) (sort (qt:class-direct-properties class) #'string<=)
              (sort (class-signals class) #'string<=)
              (sort (class-slots class) #'string<=))
      (call-next-method)))

(defmethod print-object ((object qt:object) stream)
  (if (or (not (slot-boundp object 'pointer))
          (null-pointer-p (pointer object)))
      (call-next-method)
      (if (string= "" (cxx:object-name object))
          (print-unreadable-object (object stream :type t :identity t)
            (when (smoke::const-p object)
              (princ "CONST " stream)))
          (print-unreadable-object (object stream :type t :identity t)
            (when (smoke::const-p object)
              (princ "CONST " stream))
            (princ (cxx:object-name object) stream)))))

(defmethod print-object ((object qt:meta-object) stream)
  (if (or (not (slot-boundp object 'pointer))
          (null-pointer-p (pointer object)))
      (call-next-method)
          (print-unreadable-object (object stream :type t :identity t)
            (princ (cxx:class-name object) stream))))

(defun meta-object-methods (meta-object &optional (direct-only nil))
  (loop for index from (if direct-only (cxx:method-offset meta-object) 0)
     below (cxx:method-count meta-object)
     collect (cxx:method meta-object index)))


(defun meta-object-signals (meta-object &key all)
  (mapcar #'cxx:signature
          (remove-if-not #'(lambda (m) (enum= qt:meta-method.+signal+
                                                  (cxx:method-type m)))
                         (meta-object-methods meta-object (not all)))))

(defun class-signals (class &key all)
  (meta-object-signals (cxx:static-meta-object class) :all all))

(defun meta-object-slots (meta-object &key all)
  (mapcar #'cxx:signature
          (remove-if-not #'(lambda (m) (enum= qt:meta-method.+slot+
                                                  (cxx:method-type m)))
                         (meta-object-methods meta-object (not all)))))


(defun class-slots (class &key all)
  (meta-object-slots (cxx:static-meta-object class) :all all))

(defun parent-p (object)
  (not (null-pointer-p (smoke::pointer-call
                        (smoke::make-smoke-method-from-name 
                         (find-class 'qt:object)
                         "parent")
                        (smoke::pointer object)))))


;; FIXME this might not be that smart.
(eval-startup (:compile-toplevel :execute)
  (defparameter *destroyed-slot* (qt:make-slot
                                  #'(lambda (object)
                                      (foreign-funcall-pointer
                                       (get-callback 'smoke::destructed)
                                       () :pointer (smoke:pointer object))))))

(defvar *toplevel-objects* nil)

(defun ensure-smoke-parent (object)
  (declare (optimize (speed 3)))
  (let ((parent (cxx:parent object)))
    (assert (not (null-pointer-p (smoke:pointer parent)))
            ()
            "The object ~A has not parent." object)
    (unless (smoke::has-pointer-p (smoke:pointer parent))
      ;; Before we ADD-OBJECT PARENT it must know its real class to
      ;; prevent a clash when the same pointer is returned by a
      ;; function with a more specific type.
      (change-class parent 
                    ;; Note: there can be classes that are not known
                    ;; to Smoke, like KDE's OxygenStyle that might
                    ;; be seen by the event-notify callback.  But
                    ;; it's probably save to assume the user will
                    ;; never use those.
                    (let ((class-name (cxx:class-name (meta-object parent))))
                      (smoke::lispify class-name (ecase (char class-name 0)
                                                   (#\Q :qt)
                                                   (#\K :kde)))))
      (smoke::add-object parent)
      (qt:connect (qt:get-signal parent "destroyed(QObject*)")
                  *destroyed-slot* qt:+direct-connection+)
      (tg:cancel-finalization parent)
      (if (null-pointer-p (smoke:pointer (cxx:parent parent)))
          (push parent *toplevel-objects*)
      (smoke::transfer-ownership-to parent (ensure-smoke-parent parent))))
    parent))

(defmethod initialize-instance :after ((object qt:object)
                                       &key (pointer nil pointer-p) &allow-other-keys)
  "Registers the object to the parent when a parent was set in the constructor
and the objects metaclass is SMOKE-WRAPPER-CLASS."
  (declare (optimize (speed 3)))
  (when (and (not pointer-p)
             (null-pointer-p (smoke::pointer object)))
    (error "Object ~A has not been constructed" object))
  (when (and (null pointer)
             (not (null-pointer-p (smoke::pointer object)))
             (parent-p object))
    (smoke::transfer-ownership-to object
                                  (ensure-smoke-parent object))))

(define-condition wrapper-gc (storage-condition)
  ((object-class :initarg :object-class
                 :documentation "The class of the gc'ed object.")
   (pointer :initarg :pointer))
  (:report (lambda (condition stream)
               (format stream "The object ~A ~A of type cxx:class
has the parent  but got garbage collected."
                       (slot-value condition 'object-class)
                       (slot-value condition 'pointer)))))

(eval-startup (:compile-toplevel :execute)
  (defparameter *get-parent*
    (smoke::make-smoke-method-from-name (find-class 'qt:object) "parent"))

  ;; FIXME this leaks memory when QCoreApplication::exec() is never
  ;; called, beause then, deleteLater() has no effect.
  (defparameter *delete-later*
    (smoke::make-smoke-method-from-name (find-class 'qt:object) "deleteLater")))

(defmethod smoke::make-finalize ((object qt:object))
  "Delete the qt:object OBJECT,
 by calling cxx:delete-later iff it has no parent."
  (let ((pointer (pointer object))
        (class (class-of object))
        (next (call-next-method)))
    (declare (function next))
    (if (typep (class-of object) 'cxx:class)
        #'(lambda ()
            (declare (optimize (speed 3)))
            (handler-case 
                (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
                    (smoke::pointer-call *delete-later* pointer)
                    (error (make-condition 'wrapper-gc
                                           :object-class class
                                           :pointer pointer)))
              (error (condition)
                (smoke::report-finalize-error condition "qt:object wrap"
                                              (name class) pointer))))
        #'(lambda ()
           (declare (optimize (speed 3)))
            (handler-case 
                (if (null-pointer-p (smoke::pointer-call *get-parent* pointer))
                    (funcall next)
                    (cerror "Ignore" "Finalizer for object with a parent called."))
              (error (condition)
                (smoke::report-finalize-error condition "qt:object"
                                              (name class) pointer)))))))


;;;
;;; The event-notify callback get called by QCoreApplication, on
;;; notification of an event.
;;;
;;; The DATA argument is an array of size three, containing the
;;; pointers:
;;;
;;;  void* receiver
;;;  void* event
;;;  void* result
;;; in that order.
;;; 
;;; Returning true marks the event as handled; false on the other hand
;;; leaves the event processing unchanged.
;;;
;;; See: QCoreApplication::notifyInternal(QObject *receiver, QEvent
;;; *event)

(cffi:defcallback event-notify smoke:cxx-bool
    ((data :pointer))
  (declare (optimize (speed 3)))
  (let ((receiver (smoke::get-object (cffi:mem-aref data :pointer 0)))
        (event (cast-event
                (make-instance 'qt:event
                               :pointer (cffi:mem-aref data :pointer 1)))))
    (enum-case (cxx:type event)
      (qt:event.+child-added+
       (tg:cancel-finalization (cxx:child event))
       (when (smoke::has-pointer-p (smoke::pointer (cxx:child event)))
         (unless receiver
           (setf receiver (ensure-smoke-parent (cxx:child event))))
         (smoke::transfer-ownership-to (cxx:child event) receiver)))
      (qt:event.+child-removed+
       ;; We receive child removed events for any QObject, whether
       ;; it was constructed by Smoke or not. Only take ownership of
       ;; objects that have been constructed by Smoke.
       (when (smoke::has-pointer-p (smoke::pointer (cxx:child event)))
         (assert receiver)
         (smoke::take-ownership (cxx:child event) receiver)))))
  nil)
    
(eval-when (:compile-toplevel :load-toplevel :execute)
  (cffi:defcfun cl-smoke-register-event-notify :boolean
    (event-notify :pointer)))

(defun register-event-notify ()
  (let ((ret (cl-smoke-register-event-notify (cffi:callback event-notify))))
    (unless ret
      (error "Registering event-notify callback failed."))))

(defun check-child-parent-ownership ()
  (loop for parent being the hash-values of smoke::*object-map* do
       (loop for child in (smoke::owned-objects parent) do
            (when (typep child 'qt:object)
              (assert (eql (cxx:parent child) parent)
                      (child parent)
                      "cl-smoke thinks ~A has the parent ~A, but ~A is its parent."
                      child parent (cxx:parent child))))))

(eval-startup ()
 (register-event-notify))