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

(defgeneric qt:connect (qsignal slot &optional type)
  (:documentation "Connects a signal to a slot."))

(defgeneric qt:disconnect (qsignal slot)
  (:documentation "Disconnects a connection."))

(defgeneric qt:disconnect-all (qsignal)
  (:documentation "Disconnects all connections of QSIGNAL."))

(defun check-argument-types (signal-arguments slot-arguments)
  (assert (= (length signal-arguments) (length slot-arguments)))
  (loop for signal-arg in signal-arguments
     for slot-arg in slot-arguments do
       (if (typep signal-arg 'smoke-type)
           (assert (smoke-type= signal-arg slot-arg))
           (assert (subtypep signal-arg slot-arg)))))

;;FIXME check argument-types
(defmethod qt:connect ((qsignal qsignal) (qslot qslot) &optional type)
  (assert (or (slot-boundp (signal-object qsignal) 'argument-types)
              (slot-boundp qslot 'arguments))
          ((slot-value (signal-object qsignal) 'argument-types)
           (slot-value qslot 'arguments))
          "Argument types must be specified for at least on of
~A and ~A." qsignal qslot)
  (when (not (slot-boundp (signal-object qsignal) 'argument-types))
    (setf (argument-types (signal-object qsignal))
          (arguments qslot)))
  (when (not (slot-boundp qslot 'arguments))
    (setf  (slot-value qslot 'arguments)
           (argument-types (signal-object qsignal))))
  (check-argument-types (argument-types (signal-object qsignal))
                        (arguments qslot))
  (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
                      qslot (id qslot)
                      type
                      (types (arguments qslot)))
    (cerror "Failed to connect ~S to ~S." qsignal qslot)))

(defmethod qt:connect ((sender qsignal) (function function) &optional type)
  (let ((slot (make-instance 'qslot
                             :arg0 (signal-object sender)
                             :argument-types (argument-types (signal-object sender))
                             :slot-function function)))

    (unless (connect-id (signal-object sender) (id (signal-object sender))
                        slot (id slot)
                        type 
                        (types (argument-types (signal-object sender))))
      (cerror "Failed to connect the function ~S to the signal ~S."
              function sender))))

(defclass qt-signal-slot-name ()
  ((name :initarg :name
         :reader name)))

(defclass qt-signal (qt-signal-slot-name)
  ((sender :initarg :sender
           :reader qsender))
  (:documentation "Qt C++ signal."))

(defclass qt-slot (qt-signal-slot-name)
  ((receiver :initarg :receiver
             :reader receiver))
  (:documentation "Qt C++ slot."))

(defmethod print-object ((qt-signal qt-signal) stream)
  (print-unreadable-object (qt-signal stream :type t :identity t)
    (when (slot-boundp qt-signal 'sender)
      (princ (qsender qt-signal) stream))
    (princ " " stream)
    (when (slot-boundp qt-signal 'name)
      (princ (name qt-signal) stream))))

(defgeneric qt:get-slot (receiver name)
  (:documentation "Returns the slot of RECEIVER with NAME.")
  (:method (receiver name)
    (make-instance 'qt-slot :receiver receiver :name name))
  (:method (receiver (function function))
    "Returns a slot for RECEIVER that calls function
with RECEIVER as the first argument."
    (make-instance 'qslot 
                   :arg0 receiver
                   :slot-function #'(lambda (&rest args)
                                      (apply function (cxx:parent *this*)
                                             args)))))

(define-compiler-macro qt:get-slot (&whole form receiver name)
  "Normalize the slot name."
  (if (stringp name)
      (let ((normalized-name (cxx:data
                              (qt:meta-object.normalized-signature name))))
        (if (string= name normalized-name) ;; Avoid infinite recursion
            form
            `(qt:get-slot ,receiver ,normalized-name)))
      form))

(defun qt:get-signal (sender name)
  "Returns the signal NAME of SENDER."
  (make-instance 'qt-signal :sender sender :name name))

(define-compiler-macro qt:get-signal (&whole form sender name)
  "Normalize the signal name."
  (if (stringp name)
      (let ((normalized-name (cxx:data 
                              (qt:meta-object.normalized-signature name))))
        (if (string= name normalized-name) ;; Avoid infinite recursion
            form
            `(qt:get-signal ,sender ,normalized-name)))
      form))
  
(defmethod qt:connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)
  (unless (qt:object.connect (qsender qt-signal) (qt:qsignal (name qt-signal))
                          (receiver qt-slot) (qt:qslot (name qt-slot))
                          (or type  qt:+auto-connection+))
    (cerror "Ignore"
            "Failed to connect ~A ~A to ~A ~A."
            (qsender qt-signal) (name qt-signal)
            (receiver qt-slot) (name qt-slot))))

(defmethod qt:disconnect ((qt-signal qt-signal) (qt-slot qt-slot))
  (unless (qt:object.disconnect (qsender qt-signal) (qt:qsignal (name qt-signal))
                                (receiver qt-slot) (qt:qslot (name qt-slot)))
    (cerror "Ignore"
            "Failed to disconnect ~A ~A from ~A ~A."
            (receiver qt-slot) (name qt-slot)
            (qsender qt-signal) (name qt-signal))))

(defmethod qt:disconnect-all ((sender qt:object))
  (unless (qt:object.disconnect sender 0 0 0)
    (cerror "Ignore"
            "Failed to disconnect everything connected to ~A."
            sender)))

       
(defmethod qt:connect ((qt-signal qt-signal) (function function) &optional type)
  (let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))
         (slot (make-instance 'qslot
                              :arg0 (qsender qt-signal)
                              :slot-function function
                              :argument-types
                              (method-arguments-type (qsender qt-signal)
                                                     signal-id))))
    ;; Ensure that the slot is not gc'ed as long as the QT-SIGNAL
    ;; exists.
    ;;
    ;; FIXME: remove on disconnect.
    ;; This no not critical because the slot
    ;; object is not accessible to the user,
    ;; who thus can not connect it to other
    ;; signals.
    (if (connect-id (qsender qt-signal) signal-id
                    slot (id slot)
                    type (types (arguments slot)))
        (cxx:connect-notify (qsender qt-signal)
                            (name qt-signal))
        (cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."
                (name qt-signal) (qsender qt-signal) function))))
  
(defmethod qt:connect ((qt-signal qt-signal) (slot qslot) &optional type)
  (let ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal))))
    (if (slot-boundp slot 'arguments)
        (check-argument-types (method-arguments-type (qsender qt-signal)
                                                     signal-id)
                              (arguments slot))
        (setf (slot-value slot 'arguments)
              (method-arguments-type (qsender qt-signal) signal-id)))
    (if (connect-id (qsender qt-signal) signal-id
                    slot (id slot)
                    type (types (arguments slot)))
        (cxx:connect-notify (qsender qt-signal)
                            (name qt-signal))
        (cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."
                (name qt-signal) (qsender qt-signal) slot))))

(defmethod qt:connect ((qsignal qsignal) (slot qt-slot) &optional type)
  (let ((slot-id (find-slot-id (receiver slot) (name slot))))
    (if (slot-boundp (signal-object qsignal) 'argument-types)
        (check-argument-types (argument-types (signal-object slot))
                              (method-arguments-type (receiver slot)
                                                     slot-id))
        (setf (argument-types (signal-object qsignal))
              (method-arguments-type (receiver slot) slot-id)))
    (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))
                        (receiver slot) slot-id
                        type
                        (types (argument-types (signal-object qsignal))))
      (cerror "Failed to connect ~S to ~S." qsignal slot))))
    

(defun connect-id (sender signal-id receiver slot-id type types)
  (qt:meta-object.connect sender signal-id
                       receiver slot-id
                       (if (null type)
                           qt:+auto-connection+
                           type)
                       types))

(defun disconnect-id (sender signal-id receiver slot-id)
  (qt:meta-object.disconnect sender signal-id receiver slot-id))