(defpackage :gtk-doc-introspection
  #+(or clozure-common-lisp openmcl) (:shadowing-import-from :closer-mop #:defgeneric #:ensure-generic-function #:standard-generic-function)
  (:use :cl :gtk :gobject :gdk :iter :closer-mop)
  (:export #:get-gobject-classes
           #:generate-doc-for-class
           #:generate-texinfo-for-class
           #:generate-texinfo-for-package
           #:get-enums
           #:generate-texinfo-for-enum
           #:generate-texinfo-for-packages
           #:get-flags
           #:get-structs
           #:get-opaque-boxeds))

(in-package :gtk-doc-introspection)

(defun get-gobject-classes (package)
  (when (symbolp package) (setf package (find-package package)))
  (unless package (error "Package is NIL"))
  (iter (for symbol in-package package :external-only t)
        (for class = (find-class symbol nil))
        (when (and class (subtypep class 'gobject:g-object))
          (collect class))))

(defun get-enums (package)
  (when (symbolp package) (setf package (find-package package)))
  (iter (for (g-type-name type) in-hashtable gobject::*registered-enum-types*)
        (when (eq (symbol-package type) package)
          (collect type))))

(defun get-flags (package)
  (when (symbolp package) (setf package (find-package package)))
  (iter (for (g-type-name type) in-hashtable gobject::*registered-flags-types*)
        (when (eq (symbol-package type) package)
          (collect type))))

(defun get-structs (package)
  (when (symbolp package) (setf package (find-package package)))
  (iter (for symbol in-package package :external-only t)
        (for class = (find-class symbol nil))
        (when (and class (typep class 'structure-class))
          (collect class))))

(defun get-opaque-boxeds (package)
  (when (symbolp package) (setf package (find-package package)))
  (iter (for symbol in-package package :external-only t)
        (for class = (find-class symbol nil))
        (when (and class (subtypep class 'g-boxed-opaque))
          (collect class))))

(defvar *doc-packages* nil)

(defun generate-texinfo-for-packages (directory packages)
  (setf packages (mapcar (lambda (x)
                           (if (symbolp x)
                               (find-package x)
                               x))
                         packages))
  (ensure-directories-exist directory)
  (let ((*doc-packages* packages))
    (iter (for package in packages)
          (for file-name = (format nil "~A.ref.texi" (string-downcase (package-name package))))
          (for file-path = (merge-pathnames file-name directory))
          (generate-texinfo-for-package file-path package))))

(defun generate-texinfo-for-package (file package)
  (when (symbolp package) (setf package (find-package package)))
  (with-open-file (stream file :direction :output :if-exists :supersede)
    (let ((classes (sort (copy-list (get-gobject-classes package)) #'string< :key #'class-name))
          (enums (sort (copy-list (get-enums package)) #'string<))
          (flags (sort (copy-list (get-flags package)) #'string<))
          (structs (sort (copy-list (get-structs package)) #'string< :key #'class-name))
          (opaque-boxeds (sort (copy-list (get-opaque-boxeds package)) #'string< :key #'class-name)))
      (format stream "@menu~%")
      (format stream "* ~A Classes::~%" (string-downcase (package-name package)))
      (format stream "* ~A Structs::~%" (string-downcase (package-name package)))
      (format stream "* ~A Opaque Boxeds::~%" (string-downcase (package-name package)))
      (format stream "* ~A Enums::~%" (string-downcase (package-name package)))
      (format stream "* ~A Flags::~%" (string-downcase (package-name package)))
      (format stream "@end menu~%~%")
      
      (format stream "@node ~A Classes~%" (string-downcase (package-name package)))
      (format stream "@section ~A Classes~%~%" (string-downcase (package-name package)))
      (format stream "@menu~%")
      (iter (for class in classes)
            (format stream "* ~A::~%" (string-downcase (symbol-name (class-name class)))))
      (format stream "@end menu~%~%")
      (format stream "Reference of classes in package ~A~%~%" (package-name package))
      (iter (for class in classes)
            (generate-texinfo-for-class class stream)
            (format stream "~%"))

      (format stream "@node ~A Structs~%" (string-downcase (package-name package)))
      (format stream "@section ~A Structs~%~%" (string-downcase (package-name package)))
      (format stream "@menu~%")
      (iter (for struct in structs)
            (format stream "* ~A::~%" (string-downcase (symbol-name (class-name struct)))))
      (format stream "@end menu~%~%")
      (format stream "Reference of structs in package ~A~%~%" (package-name package))
      (iter (for struct in structs)
            (generate-texinfo-for-struct struct stream)
            (format stream "~%"))

      (format stream "@node ~A Opaque Boxeds~%" (string-downcase (package-name package)))
      (format stream "@section ~A Opaque Boxeds~%~%" (string-downcase (package-name package)))
      (format stream "@menu~%")
      (iter (for boxed in opaque-boxeds)
            (format stream "* ~A::~%" (string-downcase (symbol-name (class-name boxed)))))
      (format stream "@end menu~%~%")
      (format stream "Reference of opaque boxeds in package ~A~%~%" (package-name package))
      (iter (for boxed in opaque-boxeds)
            (generate-texinfo-for-opaque-boxed boxed stream)
            (format stream "~%"))

      (format stream "@node ~A Enums~%" (string-downcase (package-name package)))
      (format stream "@section ~A Enums~%~%" (string-downcase (package-name package)))
      (format stream "@menu~%")
      (iter (for enum in enums)
            (format stream "* ~A::~%" (string-downcase (symbol-name enum))))
      (format stream "@end menu~%~%")
      (format stream "Reference of enums in package ~A~%~%" (package-name package))
      (iter (for enum in enums)
            (generate-texinfo-for-enum enum stream)
            (format stream "~%"))
      
      (format stream "@node ~A Flags~%" (string-downcase (package-name package)))
      (format stream "@section ~A Flags~%~%" (string-downcase (package-name package)))
      (format stream "@menu~%")
      (iter (for flags-type in flags)
            (format stream "* ~A::~%" (string-downcase (symbol-name flags-type))))
      (format stream "@end menu~%~%")
      (format stream "Reference of flags in package ~A~%~%" (package-name package))
      (iter (for flags-type in flags)
            (generate-texinfo-for-flags flags-type stream)
            (format stream "~%"))
      
      )))

(defun get-class-signals (class)
  (when (typep class 'gobject-class)
    (let* ((g-type-name (gobject::gobject-class-g-type-name class))
           (signals (type-signals g-type-name :include-inherited nil)))
      signals)))

(defun generate-doc-for-signal (signal)
  signal)

(defgeneric texi-ref (object))

(defmethod texi-ref ((class class))
  (symbol-texi-ref (class-name class)))

(defun symbol-texi-ref (symbol)
  (if (member (symbol-package symbol) *doc-packages*)
      (format nil "@ref{~A}" (string-downcase (symbol-name symbol)))
      (symbol-texi symbol)))

(defun symbol-texi (symbol)
  (format nil "@code{~A}" (string-downcase (symbol-name symbol))))

(defun g-type-texi (type)
  (cond
    ((g-type= "gchararray" type) "@code{string}")
    ((g-type= "GStrv" type) "@code{(list string)}")
    ((or (g-type= +g-type-int+ type)
         (g-type= +g-type-int64+ type)
         (g-type= +g-type-long+ type)) "@code{integer}")
    ((or (g-type= +g-type-uint+ type)
         (g-type= +g-type-uint64+ type)
         (g-type= +g-type-ulong+ type)) "@code{(integer 0)}")
    ((g-type= +g-type-float+ type) "@code{single-float}")
    ((g-type= +g-type-double+ type) "@code{double-float}")
    ((g-type= +g-type-void+ type) "@code{null}")
    ((g-type= +g-type-param+ type) "@code{class-property-info}")
    ((g-type= +g-type-string+ type) "@code{string}")
    ((g-type= +g-type-boolean+ type) "@code{boolean}")
    ((g-type= +g-type-pointer+ type) "@code{foreign-pointer}")
    ((and (g-type= (g-type-fundamental type) "GBoxed")
          (gethash (g-type-string type) gobject::*g-type-name->g-boxed-foreign-info*))
     (symbol-texi-ref (gobject::g-boxed-info-name (gethash (g-type-string type)
                                                           gobject::*g-type-name->g-boxed-foreign-info*))))
    ((and (g-type= (g-type-fundamental type) "GEnum")
          (gethash (g-type-string type) gobject::*registered-enum-types*))
     (symbol-texi-ref (gethash (g-type-string type) gobject::*registered-enum-types*)))
    ((and (g-type= (g-type-fundamental type) "GFlags")
          (gethash (g-type-string type) gobject::*registered-flags-types*))
     (symbol-texi-ref (gethash (g-type-string type) gobject::*registered-flags-types*)))
    ((and (or (g-type= (g-type-fundamental type) "GObject")
              (g-type= (g-type-fundamental type) "GInterface"))
          (gethash (g-type-string type) gobject::*registered-object-types*))
     (symbol-texi-ref (gethash (g-type-string type) gobject::*registered-object-types*)))
    (t (g-type-string type))))

(defun generate-texinfo-for-class (class stream)
  (when (symbolp class) (setf class (find-class class)))
  (format stream "@node ~A~%" (string-downcase (symbol-name (class-name class))))
  (format stream "@subsection ~A~%"(string-downcase (symbol-name (class-name class))))
  (format stream "@Class ~A~%~%" (string-downcase (symbol-name (class-name class))))
  (format stream "Superclasses: ~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-superclasses class)))
  (format stream "Slots:~%")
  (let ((slots (sort (copy-list (class-direct-slots class)) #'string< :key #'slot-definition-name)))
    (if (null slots)
        (format stream "None~%~%")
        (progn
          (format stream "@itemize~%")
          (iter (for slot in slots)
                (generate-texinfo-for-slot class slot stream))
          (format stream "@end itemize~%"))))
  (format stream "Signals:~%")
  (let ((signals (sort (copy-list (get-class-signals class)) #'string< :key #'signal-info-name)))
    (if (null signals)
        (format stream "None~%~%")
        (progn
          (format stream "@itemize~%")
          (iter (for signal in signals)
                (generate-texinfo-for-signal class signal stream))
          (format stream "@end itemize~%")))))

(defun generate-texinfo-for-struct (class stream)
  (when (symbolp class) (setf class (find-class class)))
  (format stream "@node ~A~%" (string-downcase (symbol-name (class-name class))))
  (format stream "@subsection ~A~%"(string-downcase (symbol-name (class-name class))))
  (format stream "@Class ~A~%~%" (string-downcase (symbol-name (class-name class))))
  (format stream "Superclasses: ~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-superclasses class)))
  (format stream "Subclasses: ")
  (if (class-direct-subclasses class)
      (format stream "~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-subclasses class)))
      (format stream "None~%~%"))
  (format stream "Slots:~%")
  (let ((slots (sort (copy-list (class-direct-slots class)) #'string< :key #'slot-definition-name)))
    (if (null slots)
        (format stream "None~%~%")
        (progn
          (format stream "@itemize~%")
          (iter (for slot in slots)
                (generate-texinfo-for-slot class slot stream))
          (format stream "@end itemize~%")))))

(defun generate-texinfo-for-opaque-boxed (class stream)
  (when (symbolp class) (setf class (find-class class)))
  (format stream "@node ~A~%" (string-downcase (symbol-name (class-name class))))
  (format stream "@subsection ~A~%"(string-downcase (symbol-name (class-name class))))
  (format stream "@Class ~A~%~%" (string-downcase (symbol-name (class-name class))))
  (format stream "Superclasses: ~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-superclasses class)))
  (format stream "Slots:~%")
  (let ((slots (sort (copy-list (class-direct-slots class)) #'string< :key #'slot-definition-name)))
    (if (null slots)
        (format stream "None~%~%")
        (progn
          (format stream "@itemize~%")
          (iter (for slot in slots)
                (generate-texinfo-for-slot class slot stream))
          (format stream "@end itemize~%")))))

(defun generate-texinfo-for-slot (class slot stream)
  (format stream "@item ~A" (string-downcase (slot-definition-name slot)))
  (ignore-errors
    (when (typep slot 'gobject::gobject-property-direct-slot-definition)
      (let* ((class-g-type (gobject::gobject-class-g-type-name class))
             (property-name (gobject::gobject-property-direct-slot-definition-g-property-name slot))
             (property (if (g-type= (g-type-fundamental class-g-type) "GInterface")
                           (find property-name (interface-properties class-g-type)
                                 :key #'g-class-property-definition-name
                                 :test #'string=)
                           (class-property-info class-g-type property-name))))
        (format stream ". Type: ~A (flags:~@[~* readable~]~@[~* writable~]~@[~* constructor~]~@[~* constructor-only~])~%~%"
                (g-type-texi (g-class-property-definition-type property))
                (g-class-property-definition-readable property)
                (g-class-property-definition-writable property)
                (g-class-property-definition-constructor property)
                (g-class-property-definition-constructor-only property)))))
  (format stream "~%~%"))

(defun generate-texinfo-for-signal (class signal stream)
  (declare (ignore class))
  (format stream "@item ~A. (~{~A~^, ~}) -> ~A ~@[ [~{~A~^, ~}]~]~%~%"
          (signal-info-name signal)
          (mapcar #'g-type-texi (signal-info-param-types signal))
          (g-type-texi (signal-info-return-type signal))
          (mapcar (lambda (x) (string-downcase (symbol-name x)))
                  (signal-info-flags signal))))

(defun generate-texinfo-for-enum (enum stream)
  (format stream "@node ~A~%" (string-downcase enum))
  (format stream "@subsection ~A~%" (string-downcase enum))
  (format stream "@Enum ~A~%" (string-downcase enum))
  (format stream "Values:~%")
  (format stream "@itemize~%")
  (iter (for v in (cffi::foreign-enum-keyword-list enum))
        (format stream "@item ~A~%" (string-downcase (format nil "~S" v))))
  (format stream "@end itemize~%~%"))

(defun generate-texinfo-for-flags (flags stream)
  (format stream "@node ~A~%" (string-downcase flags))
  (format stream "@subsection ~A~%" (string-downcase flags))
  (format stream "@Flags ~A~%" (string-downcase flags))
  (format stream "Values:~%")
  (format stream "@itemize~%")
  (iter (for v in (cffi::foreign-bitfield-symbol-list flags))
        (format stream "@item ~A~%" (string-downcase (format nil "~S" v))))
  (format stream "@end itemize~%~%"))