~scymtym/+junk/cl-gir

;;; model.lisp --- GObject Introspection Data Model.
;;
;; Copyright (C) 2010, 2011 Jan Moringen
;;
;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
;;
;; This Program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This Program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses>.

(in-package :gi)


;;; Find Node Protocol
;;

(defgeneric find-node (which where
		       &key recursive type key test)
  (:documentation
   ""))

(defmethod find-node ((which t) (where t)
		      &key recursive type key test)
  (declare (ignore which where recursive type key test))
  nil)


;;;
;;

(defclass node ()
  ((name         :initarg  :name
		 ;;:type     string ;;symbol
		 :accessor node-name
		 :documentation
		 "")
   (foreign-name :initarg  :foreign-name
		 ;;:type     string
		 :initform nil
		 :accessor node-foreign-name
		 :documentation
		 "")
   (doc          :initarg  :doc
		 :type     (or null string)
		 :initform nil
		 :accessor node-doc
		 :documentation
		 ""))
  (:documentation
   "Superclass of all GObject introspection nodes."))

(defmethod make-name-string ((node node))
  (with-slots (name foreign-name) node
    (format nil "~S~:[~;~:* [~S]~]" name foreign-name)))

(defmethod print-object ((object node) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (write-string (make-name-string object) stream)))

;; TODO composite-mixin?
(defclass composite (node)
  ((children :initarg  :children
	     :type     list
	     :initform nil
	     :accessor composite-children
	     :documentation
	     ""))
  (:documentation
   "Mixin class for model classes the instances of which contain child
elements."))

(defmethod print-object ((object composite) stream)
  (with-slots (children) object
    (print-unreadable-object (object stream :type t :identity t)
      (format stream "~A" ;;"~A~%~{~2t~S~%~}"
	      (make-name-string object) ;;children
	      ))))

(defmethod find-node ((which t) (where composite) ;; TODO which is not used
		      &key
		      (recursive t)
		      type
		      (key       #'node-name) ;; TODO should be #'identity?
		      (test      #'eq))
  (with-slots (children) where
    (apply
     #'append
     (remove-if-not test children :key key)
     (when recursive
       (mapcar
	(lambda (child)
	  (find-node
	   which child
	   :recursive t :type type :key key :test test))
	children)))))

(defclass typed-mixin ()
  ((type :initarg  :type
	 ;;:type     string
	 :accessor node-type
	 :documentation
	 "")) ;; TODO should probably not store a string here
  (:documentation
   "Mixin class for model classes that have an associated type."))

(defmethod initialize-instance :after ((node typed-mixin) &key)
  "DOC"
  (unless (slot-boundp node 'type)
    (setf (slot-value node 'type)
	  (first
	   (find-node :currently-ignored-anyway node
		      :key #'identity
		      :test #'(lambda (child) (typep child 'type1))))))) ;; TODO sucks

(defmethod print-object ((object typed-mixin) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~A of-type ~A"
	    (make-name-string object)
	    (if (slot-boundp object 'type)
		(slot-value object 'type)
		:?type))))

(defclass value-mixin ()
  ((value :initarg  :value
	  :type     string
	  :accessor node-value
	  :documentation
	  "")) ;; TODO should probably not store a string here
  (:documentation
   "Mixin class for model classes that have a value attribute."))

(defmethod print-object ((object value-mixin) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~A = ~S"
	    (make-name-string object)
	    (if (slot-boundp object 'value)
		(slot-value object 'value)
		"?value"))))

(defclass version-mixin ()
  ((version :initarg  :version
	    :type     list
	    :documentation
	    ""))
  (:documentation
   "Mixin class for model classes that have a version attribute."))

(defclass g-type-mixin ()
  ((type-name   :initarg  :type-name
		:type     string
		:accessor class-type-name ;; TODO rename
		:documentation
		"")
   (type-getter :initarg  :type-getter
		:type     string
		:accessor class-type-getter
		:documentation
		""))
  (:documentation
   "Mixin class for model classes that have an associated glib
type."))

(defclass class-mixin (g-type-mixin)
  ((properties :initarg  :properties
	       :type     list
	       :accessor class-properties
	       :documentation
	       "")
   (fields     :initarg  :fields
	       :type     list
	       :accessor class-fields
	       :documentation
	       ""))
  (:documentation
   "Mixin class for model classes that exhibit class-like
structure."))

(defmethod initialize-instance :after ((node class-mixin) &key)
  (unless (slot-boundp node 'properties)
    (setf (slot-value node 'properties)
	  (remove-if-not (rcurry #'typep 'property)
			 (slot-value node 'children))))

  (unless (slot-boundp node 'fields)
    (setf (slot-value node 'fields)
	  (remove-if-not (rcurry #'typep 'field)
			 (slot-value node 'children)))))

(defclass signature-mixin ()
  ((return-type :initarg  :return-type
		:type     (or null type1) ;; TODO null should not be allowed
		:accessor function-return-type
		:documentation
		"")
   (parameters :initarg  :parameters
	       :type     list
	       :accessor function-parameters
	       :documentation
	       ""))
  (:documentation
   "This mixin class adds a return type and parameters to
subclasses."))

(defmethod initialize-instance :after ((node signature-mixin) &key)
  "Find and store return type and parameter types."
  (unless (slot-boundp node 'return-type)
    (setf (slot-value node 'return-type)
	  (find-if (rcurry #'typep 'type1)
		   (slot-value node 'children))))

  (unless (slot-boundp node 'parameters)
    (setf (slot-value node 'parameters)
	  (remove-if-not (rcurry #'typep 'parameter)
			 (slot-value node 'children)))))

(defmethod function-some-out-parameters? ((node signature-mixin))
  (some #'parameter-out? (slot-value node 'parameters)))


;;;
;;

(defclass repository (composite)
  ()
  (:documentation
   "DOC"))

(defclass include (node
		   version-mixin)
  ()
  (:documentation
   "DOC"))

(defclass package1 (composite)
  ()
  (:documentation
   "DOC"))

(defclass namespace (composite)
  ((prefix         :initarg  :prefix
		   :type     string
		   :documentation
		   "")
   (shared-library :initarg  :shared-library
		   :type     string
		   :accessor namespace-shared-library
		   :documentation
		   ""))
  (:documentation
   "DOC"))

(defclass alias (node)
  ((target :initarg  :target
	   :type     string
	   :documentation
	   "")
   (type   :initarg  :type
	   :type     string
	   :documentation
	   ""))
  (:documentation
   "DOC"))

(defclass constant (typed-mixin
		    value-mixin
		    node)
  ()
  (:documentation
   "DOC"))

(defclass type1 (node)
  ()
  (:documentation
   "DOC"))

(defclass array1 (type1
		  typed-mixin)
  ((length     :initarg  :length
	       :type     (or null non-negative-integer)
	       :documentation
	       "")
   (fixed-size :initarg  :fixed-size
	       :type     non-negative-integer
	       :documentation
	       ""))
  (:documentation
   "DOC"))

;; TODO avoid this constructor
(defmethod initialize-instance :around ((instance array1)
					&rest initargs
					&key children)
  (when children
    (setf (getf initargs :type) (first children))
    (remove-from-plistf initargs :children))
  (apply #'call-next-method instance initargs))

(defclass callback (type1
		    function1)
  ()
  (:documentation
   "DOC"))

(defclass union1 (composite
		  g-type-mixin)
  ()
  (:documentation
   "DOC"))

(defclass enumeration (composite
		       g-type-mixin)
  ()
  (:documentation
   "DOC"))

(defclass bitfield (version-mixin
		    composite
		    g-type-mixin)
  ()
  (:documentation
   "DOC"))

(defclass member1 (value-mixin node)
  ((nick :initarg  :nick
	 :type     string
	 :accessor value-nick
	 :documentation
	 ""))
  (:documentation
   "DOC"))

(defclass interface (composite
		     class-mixin
		     version-mixin) ;; TODO add composite to class-mixin?
  ()
  (:documentation
   "DOC"))

(defclass class1 (composite
		  class-mixin
		  version-mixin)
  ((parent                 :initarg  :parent
			   :accessor class-parent
			   ;; TODO type
			   :documentation
			   "")
   (implemented-interfaces :initarg  :interfaces-interfaces
			   :type     list
			   :accessor class-implemented-interfaces
			   :documentation
			   "")
   (abstract               :initarg  :abstract
			   :type     boolean
			   :accessor class-abstract
			   :initform nil
			   :documentation
			   ""))
  (:documentation
   "DOC"))

(defclass record (composite
		  class-mixin)
  ()
  (:documentation
   "DOC"))

;; TODO relation between property and field?
(defclass property (typed-mixin
		    composite)
  ((writable :initarg  :writable
	     :type     boolean
	     :accessor property-writable
	     :initform nil
	     :documentation
	     ""))
  (:documentation
   "DOC"))

(defclass field (typed-mixin
		 composite)
  ()
  (:documentation
   "DOC"))

(defclass signal1 (composite
		   signature-mixin
		   version-mixin)
  ()
  (:documentation
   "Instances represent signals."))

(defclass function1 (composite
		     signature-mixin)
  ()
  (:documentation
   "Instance represent functions."))

(defclass method1 (function1)
  ()
  (:documentation
   "DOC"))

(defclass virtual-method (method1)
  ((invoker :initarg  :invoker
	    ;;:type     TYPE
	    :documentation
	    ""))
  (:documentation
   "DOC"))

(defclass constructor (method1)
  ()
  (:documentation
   "DOC"))

(defclass parameter (composite) ;; TODO typed-mixin?
  ((type      :initarg  :type
	      ;;:type     type1
	      :accessor parameter-type
	      :documentation
	      "")
   (direction :initarg  :direction
	      ;;:type     string
	      :accessor parameter-direction
	      :documentation
	      ""))
  (:documentation
   "DOC"))

(defmethod initialize-instance :after ((node parameter) &key)
  "DOC"
  (unless (slot-boundp node 'type)
    (setf (slot-value node 'type)
	  (find-if (rcurry #'typep 'type1)
		   (slot-value node 'children)))))

(defmethod parameter-out? ((node parameter))
  (member (slot-value node 'direction) '("out" "inout")
	  :test #'string=))

(defclass varargs (parameter)
  ()
  (:documentation
   "DOC"))