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

(defclass qsignal-mixin ()
  ((signal-object :accessor signal-object
                  :initarg :signal-object
                  :initform (make-instance 'signal-object)))
  (:documentation "in SB-PCL you can not have both
FUNCALLABLE-STANDARD-CLASS and STANDARD-CLASS,
thus QSIGNAL is split in three classes.

See: 
 http://www.sbcl.org/manual/Metaobject-Protocol.html#index-validate_002dsuperclass-164"))
  
(defclass signal-object (qt:object)
  ((argument-types :accessor argument-types
                   :initarg :argument-types
                   :documentation "List of the argument types"))
  (:documentation "Qt Signal object.")
  (:metaclass cxx:class))

#+cmu (defmethod closer-mop:validate-superclass ((class closer-mop:funcallable-standard-class)
                                           (superclass standard-class))
  t)

(defclass qsignal (closer-mop:funcallable-standard-object qsignal-mixin)
  ()
  (:metaclass closer-mop:funcallable-standard-class)
  (:documentation "A funcallable Qt signal.
The argument types can be supplied by the :METHOD-TYPES initarg.
Calling an instance emits the signal."))

(defun qt:make-signal (&rest argument-types)
  "Returns a funcallable signal. When ARGUMENT-TYPES are not
specified, they are determined when the first connection is made."
  (if argument-types
    (make-instance 'qsignal :argument-types argument-types)
    (make-instance 'qsignal)))

(defmethod id ((qsignal signal-object))
  (cxx:method-count (cxx:meta-object qsignal)))

(defmethod initialize-instance :after ((object qsignal) &rest initargs
                                       &key (argument-types nil arg-types-p)
                                       &allow-other-keys)
  (declare (ignore initargs))
  (when arg-types-p
    (setf (argument-types (signal-object object))
          argument-types))
  (closer-mop:set-funcallable-instance-function object
                                                #'(lambda (&rest args)
                                                    (apply #'emit (signal-object object) args))))

(defun find-slot-id (receiver slot)
  "Returns the ID of RECEIVER from SLOT."
  ;; For efficiency assume that SLOT is normalized and fallback to
  ;; normalizing when not. (Just like Qt does.)
  (let ((id (cxx:index-of-slot (cxx:meta-object receiver)
                               slot)))
    (when (< id 0)
      (setf id (cxx:index-of-slot (cxx:meta-object receiver)
                                  (qt:meta-object.normalized-signature slot))))
    (when (< id 0)
      (error "No slot ~S for class ~S.
The valid slots are: ~{~<~%~T~0,75:;~A ~>~}"
             slot (class-of receiver)
             (class-slots (class-of receiver))))
    id))


(defun make-lisp-object (object)
  (make-cleanup-pointer (make-cxx-lisp-object object)
                        #'cl-smoke-free-lisp-object))
                        

(defun convert-arguments (arguments types)
  "Returns a list of ARGUMENTS converted to TYPES."
  (mapcar #'(lambda (argument type)
              (if (typep type 'smoke-type)
                  (smoke:convert-argument argument type)
                  (progn (assert (typep argument type)
                                 ()
                                 "The argument ~S is not of type ~S."
                                 argument type)
                         (make-lisp-object argument))))
          arguments types))
  
(defun emit (qsignal &rest arguments)
  "Emits the signal QSIGNAL."
  (activate qsignal (id qsignal) (argument-types qsignal) arguments))

(defun activate (object id types arguments)
  ;;; The first element of args would be used for the return value by
  ;;; QMetaObject::invokeMethod(), but for signal-slot connection it is
  ;;; ignored.
  (smoke::with-stack (stack (convert-arguments arguments types)
                            types)
    (with-foreign-object (args :pointer (1+ (length arguments)))
      (loop for i from 1 to (smoke:size stack)
         for type in types
         do
           (setf (mem-aref args :pointer i)
                 (if (or (not (typep type (find-class 'smoke-type)))
                         (= 0 (type-id type))
                         (= 13 (type-id type)))
                     (foreign-slot-value
                      (mem-aref (smoke::call-stack-pointer stack)
                                'smoke::smoke-stack-item
                                i)
                      'smoke::smoke-stack-item 'smoke::voidp)
                     (foreign-slot-pointer
                      (mem-aref (smoke::call-stack-pointer stack)
                                'smoke::smoke-stack-item
                                i)
                      'smoke::smoke-stack-item 'smoke::voidp))))
      (setf (mem-aref args :pointer 0)
            (null-pointer))
      (qt:meta-object.activate object id args))))

(defmethod qt:disconnect-all ((qsignal qsignal))
  (unless (disconnect-id (signal-object qsignal)
                         (id (signal-object qsignal))
                         0
                         0)))