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

(defmethod print-object ((variant qt:variant) stream)
  "Print the type and value of the variant."
  (if (or (not (slot-boundp variant 'pointer))
          (null-pointer-p (pointer variant)))
      (call-next-method)
      (print-unreadable-object (variant stream :type t :identity t)
        (format stream "~A~@[ ~S~]" 
                (cxx:type-name variant)
                (handler-case (qt:from-variant variant)
                  (error () nil))))))

(defun qt:make-variant (&optional (value nil value-p))
  "Returns a new VARIANT containing a C++ version of VALUE
or an empty variant when VALUE is not specified."
  (if value-p
      (make-instance 'qt:variant :arg0 value)
      (make-instance 'qt:variant)))

(defun qt:make-char (character)
  "Returns a char for a lisp CHARACTER."
  (let ((octets (babel:string-to-octets (string character))))
    (case (length octets)
      (1 (make-instance 'qt:char :arg0 (aref octets 0)))
      (2 (make-instance 'qt:char :args (list (aref octets 0)
                                             (aref octets 1))))
      (t (error "qt:char requires the character ~A to be encoded
in one or two octets, but it is using ~A."
                character (length octets))))))

(defun surrogate-p (char)
  (or (cxx:is-high-surrogate char)
      (cxx:is-low-surrogate char)))

(defun qt:from-char (char)
  "Returns the Lisp character represented by CHAR."
  (assert (not (surrogate-p char))
          (char)
          "The char ~A is part of a surrogate.")
  (char
   (babel:octets-to-string (make-array 2 :element-type '(unsigned-byte 8)
                                       :initial-contents
                                       (list
                                        (char-code (cxx:cell char))
                                        (char-code (cxx:row char)))))
   0))

(defmethod print-object ((char qt:char) stream)
  (if (or (null-pointer-p (pointer char))
          (surrogate-p char))
      (call-next-method)
      (print-unreadable-object (char stream :type t)
        (princ (qt:from-char char) stream))))


;; FIXME include in MAKE-VARIANT? how??
(defun qt:make-lisp-variant (value)
  "Returns a new VARIANT that wraps VALUE.

The variant contains the actual Lisp object VALUE
and not its C++ value like in MAKE-VARIANT."
  (let ((object (make-cxx-lisp-object value)))
    (unwind-protect
         (make-instance 'qt:variant :args (list *cxx-lisp-object-metatype*
                                                object))
      (free-cxx-lisp-object object))))

(defcfun cl-smoke-lisp-object-value :pointer
  (variant :pointer))

(defun qt:variant-boundp (variant)
  "Returns true when VARIANT is valid (has a value) and false otherwise."
  (cxx:is-valid variant))

(defun copy-object-from-pointer (class pointer)
  (make-instance class :arg0 (make-instance class :pointer pointer)))

(eval-startup ()
;; *cxx-lisp-object-metatype* can change when loading an image
(eval '
 (macrolet
     ((variant-conversions ((variant) &body types)
        (let* ((special-types '(long-long ulong-long map list hash))
               (exclude-types
                (append '(63) ;; ColorGroup
                        (mapcar #'(lambda (s)
                                    (value
                                     (symbol-value
                                      (intern (format nil "VARIANT.+~A+" s)
                                              :qt))))
                                special-types)))
               (qt-types (loop for i from 1 to (value qt:variant.+user-type+)
                            when (and (qt:variant.type-to-name i)
                                      ;; type-to-name returns longlong but
                                      ;; should be LongLong
                                      (not (member i exclude-types)))
                            collect
                              (smoke::lispify (qt:variant.type-to-name i)
                                              :qt))))
          `(ecase (cxx:user-type ,variant)
             ,@(loop for type in (append special-types
                                         (remove nil qt-types))
                  collect
                    `(,(value (symbol-value 
                               (let ((*package*
                                      (find-package :cl-smoke.qt)))
                                 (symbolicate 'variant.+ type '+))))
                       ,(if (fboundp (intern (format nil "TO-~A" type) :cxx))
                            `(,(intern (format nil "TO-~A" type) :cxx) ,variant)
                            `(copy-object-from-pointer
                              ;; intern since these types are in
                              ;; qt.gui not qt.core
                              (intern ,(symbol-name type) :qt)
                              (cxx:const-data ,variant)))))
             ,@(loop for type in types
                  collect
                    `(,(eval (first type))
                       ,@(rest type)))))))
   (defun qt:from-variant (variant)
     "Returns the value of VARIANT."
     (variant-conversions (variant)
                          ((value qt:variant.+invalid+)
                           (cerror "Return (VALUES)" "Type of variant ~A is invalid." variant)
                           (values))
                          (*cxx-lisp-object-metatype*
                           (let* ((lisp-object (cl-smoke-lisp-object-value (pointer variant)))
                                  (value))
                             (setf value (translate-cxx-lisp-object lisp-object))
                             (free-cxx-lisp-object lisp-object)
                             value)))))))
    
(defmethod qt:value ((variant qt:variant))
  "Returns the value of VARIANT."
  (qt:from-variant variant))

(defmethod (setf qt:value) (new-value (variant qt:variant))
  (cxx:operator= variant (qt:make-variant new-value))
  new-value)