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

(defbitfield qlist-data-flags
  :sharable)

(defcstruct qlist-data
  (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int)))
  (alloc :int)
  (begin :int)
  (end :int)
  (flags qlist-data-flags)
  (array :pointer))

(defcstruct qlist
  (data (:pointer qlist-data)))

(defun qlist-size (qlist)
  (let ((data (foreign-slot-value qlist 'qlist 'data)))
    (- (foreign-slot-value data 'qlist-data 'end)
       (foreign-slot-value data 'qlist-data 'begin))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (macrolet ((c-name (name)
               `(nth-value 1 ,name))
             (fun-names-let (name-pre-post-fixes &body body)
               `(flet (,@(mapcar
                          #'(lambda (npp)
                              `(,(first npp) (type)
                                 (values
                                  (intern (string-upcase
                                           (concatenate 'string
                                                        ,(second npp)
                                                        type
                                                        ,(third npp)))
                                          ,*package*)
                                  (concatenate 'string
                                               (substitute #\_ #\-
                                                           ,(second npp))
                                               type
                                               (substitute #\_ #\-
                                                           ,(third npp))))))
                          name-pre-post-fixes))
                  ,@body)))
    (fun-names-let ((list-free "cl-smoke-free-list-")
                    (list-make "cl-smoke-make-list-")
                    (list-at "cl-smoke-list-" "-at")
                    (list-append "cl-smoke-list-" "-append"))
                   (defmacro define-qlist-wrapper (type-name element-type &optional (c-name nil c-name-p)
                                                   &key def-cfuns)
                     (let* ((c-name (or c-name type-name))
                            (type c-name)
                            (lisp-type (symbolicate 'qlist- element-type)))
                       `(progn
                          ,(when (or (not c-name-p) def-cfuns)
                                 `(progn
                                    (defcfun ,(c-name (list-free type)) :void
                                      "Frees LIST."
                                      (list :pointer))
                                    (defcfun ,(c-name (list-make type)) :pointer
                                      "Makes a list.")
                                    (defcfun ,(c-name (list-at type)) :pointer
                                      "Returns the a newly constructed copy of the element at
 position AT of LIST."
                                      (list :pointer)
                                      (index :int))
                                    (defcfun ,(c-name (list-append type)) :pointer
                                      "Appends NEW-ELEMENT to LIST."
                                      (list :pointer)
                                      (new-element :pointer))))
                          ;; To Lisp
                          ,@(loop for type-name in (ensure-list type-name) collect
                                 `(defun ,(symbolicate 'from-list- type-name) (list-pointer)
                                    (declare (optimize (speed 3)))
                                    (let ((vector (make-array (qlist-size
                                                               list-pointer))))
                                      (dotimes (index (length vector) vector)
                                        (setf (elt vector index)
                                              ;; FIXME the returned object is not wrapped by Smoke
                                              ;; -> change this? 
                                              (object-to-lisp
                                               (,(list-at type)
                                                 list-pointer index)
                                               (make-smoke-type ,(symbolicate '*smoke-module*)
                                                                ,type-name)))))))
                          ,@(loop for type-name in (ensure-list type-name) collect
                                 `(define-to-lisp-translation
                                      (,(format nil "const QList<~A>&" type-name)
                                        ,(format nil "QList<~A>" type-name))
                                      ,(symbolicate 'from-list- type-name)
                                    ,(list-free type)))
                          ;; From Lisp
                          (defun ,(symbolicate 'coerce- lisp-type) (list)
                            (let ((qlist (,(list-make type))))
                              (loop for element across list do
                                   (,(list-append type)
                                     qlist (pointer (make-instance ',element-type :args (list element)))))
                              (make-cleanup-pointer
                               qlist
                               (function ,(list-free type)))))
                          (defun ,(symbolicate lisp-type '-p) (list)
                            (every #'(lambda (element)
                                        ;(typep element ',element-type))
                                       (typep element (find-class ',element-type)))
                                   list))
                          ,@(loop for type-name in (ensure-list type-name) collect
                                 `(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name)
                                                                  ,(format nil "QList<~A>" type-name))
                                      ;; FIXME allow sequence
                                      (and (vector );,element-type)
                                           (satisfies ,(symbolicate lisp-type '-p)))
                                    ,(symbolicate 'coerce- lisp-type)))))))))

(define-qlist-wrapper "QVariant" qt:variant)

(define-qlist-wrapper "QByteArray" qt:byte-array)

(define-qlist-wrapper "QObject*" qt:object "void" :def-cfuns t)