[Use standard-presentation-class metaclass
clinton@unknownlamer.org**20070911184433
 This is the first step to porting ucw-presentations to the
 interface-element substrate.
 
 * New metaclass: standard-presentation-class as an extension of
   standard-component-class. Provides a :presentation slot option that
   behaves like :component except that TYPE-NAME is a presentation slot
   type.
 * Removed the slots field from every compound presentation.  
 * Reworked all of the presentation code to use the new
   presentation-slots accessor.
] {
hunk ./src/presentations.lisp 7
+  (:metaclass standard-presentation-class)
hunk ./src/presentations.lisp 37
+(defmethod presentation-slots ((presentation presentation))
+  (mapcar #'(lambda (slot-name)
+	      (slot-value presentation slot-name))
+	  (presentation-slots (class-of presentation))))
+
hunk ./src/presentations.lisp 62
-  ((slots :accessor slots :initarg :slots :initform nil)
-   (instance :initform nil :initarg :instance :accessor instance))
+  ((instance :initform nil :initarg :instance :accessor instance))
+  (:metaclass standard-presentation-class)
hunk ./src/presentations.lisp 75
-    (dolist (slot (slots pres))
+    (dolist (slot (presentation-slots pres))
hunk ./src/presentations.lisp 91
-  (find slot-label (slots o) :test #'string= :key #'label))
+  (find slot-label (presentation-slots o) :test #'string= :key #'label))
hunk ./src/presentations.lisp 100
-  ())
+  ()
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 115
-	  :documentation "Text to render after all the slots have been rendered.")))
+	  :documentation "Text to render after all the slots have been rendered."))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 121
-  (when (slots pres)
-    (present-slot (first (slots pres)) (instance pres)))
-  (dolist (slot (cdr (slots pres)))
+  (when (presentation-slots pres)
+    (present-slot (first (presentation-slots pres)) (instance pres)))
+  (dolist (slot (cdr (presentation-slots pres)))
hunk ./src/presentations.lisp 132
-  ((slots :accessor slots :initarg :slots)
-   (editablep :accessor editablep :initform t :initarg :editablep)
+  ((editablep :accessor editablep :initform t :initarg :editablep)
hunk ./src/presentations.lisp 136
-   (instances :accessor instances)))
+   (instances :accessor instances))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 163
-    (dolist (slot (slots listing))
+    (dolist (slot (presentation-slots listing))
hunk ./src/presentations.lisp 172
-    (dolist (slot (slots listing))
+    (dolist (slot (presentation-slots listing))
hunk ./src/presentations.lisp 214
-		      :documentation "The presentation object used when showing the results.")))
+		      :documentation "The presentation object used when showing the results."))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 222
-    (dolist (slot (slots (search-presentation search)))
+    (dolist (slot (presentation-slots (search-presentation search)))
hunk ./src/presentations.lisp 228
-  ((presentation :accessor presentation :initarg :presentation)))
+  ((presentation :accessor presentation :initarg :presentation))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 251
-  ((search-presentation :accessor search-presentation)))
+  ((search-presentation :accessor search-presentation))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 260
-	(dolist (slot (slots (list-presentation s)))
+	(dolist (slot (presentation-slots (list-presentation s)))
hunk ./src/presentations.lisp 269
-              (dolist (slot (slots (list-presentation s)))
+              (dolist (slot (presentation-slots (list-presentation s)))
hunk ./src/presentations.lisp 310
-  ((criteria :accessor criteria :initform nil)))
+  ((criteria :accessor criteria :initform nil))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 347
-   (print-object-label)))
+   (print-object-label))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 376
-(defvar *slot-type-mapping* (make-hash-table :test 'eql))
+;; NOTE: *slot-type-mapping* and find-slot-presentation-class-name
+;; were moved to standard-presentation-class.lisp
hunk ./src/presentations.lisp 386
-       ,@(remove :type-name options :key #'car))
+       ,@(remove :type-name options :key #'car)
+       (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 418
-     `(defcomponent ,class-name ,supers ,slots)
+     `(defcomponent ,class-name ,supers
+	,slots
+	(:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 474
-  ((search-text :accessor search-text :initform nil)))
+  ((search-text :accessor search-text :initform nil))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 519
-  ((number-input :accessor number-input :initform nil)))
+  ((number-input :accessor number-input :initform nil))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 597
-  ())
+  ()
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 695
+		 :presentation nil
hunk ./src/presentations.lisp 701
+			:presentation nil
hunk ./src/presentations.lisp 706
-		:documentation "Can this relation not exist.")))
+		:documentation "Can this relation not exist."))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 720
-  ((criteria :accessor criteria :initform '())))
+  ((criteria :accessor criteria :initform '()))
+  (:metaclass standard-presentation-class))
hunk ./src/presentations.lisp 938
-(defmacro slot-presentations (&rest slot-specs)
+
+#|(defmacro slot-presentations (&rest slot-specs)
hunk ./src/presentations.lisp 941
-		     (let ((class-name (gethash (car slot) *slot-type-mapping*)))
+		     (let ((class-name (find-slot-presentation-class-name
+					(car slot))))
hunk ./src/presentations.lisp 947
+|#
hunk ./src/presentations.lisp 950
-  `(defcomponent ,name ,supers
-     ()
-     (:default-initargs
-       ,@(when slots `(:slots (slot-presentations ,@slots)))
-       ,@default-initargs)))
+  (flet ((slot-presentations (slots)
+	   (mapcar #'(lambda (slot)
+		       `(,(gensym) :presentation (,(car slot) ,@(cdr slot))))
+		   slots)))
+    `(defcomponent ,name ,supers
+       ,(slot-presentations slots)
+       (:metaclass standard-presentation-class)
+       (:default-initargs ,@default-initargs))))
addfile ./src/standard-presentation-class.lisp
hunk ./src/standard-presentation-class.lisp 1
-
+(in-package :it.bese.ucw.presentations)
+
+;;; Presentation Metaobject Code
+;; This is a slight extension of the standard-component-class that
+;; registers presentations classes and component slots which allows
+;; them to be called properly from other presentations instead of
+;; just rendered
+
+
+;;; Slot type mapping code
+;; This should be in presentations.lisp, but has to be here so that
+;; the metaobject protocol extensions can work properly. This is
+;; temporary, and once everything has been ported to work on top of
+;; the interface-element classes this bit of code can be safely
+;; removed
+(defvar *slot-type-mapping* (make-hash-table :test 'eql))
+
+(defun find-slot-presentation-class-name (slot-presentation-type)
+  (gethash slot-presentation-type *slot-type-mapping*))
+
+(defclass standard-presentation-class (standard-component-class)
+  ((presentation-slots :initform nil :accessor presentation-slots)))
+
+(defclass standard-presentation-direct-slot (ucw::standard-component-direct-slot)
+  ((presentation :initarg :presentation :accessor presentation-slot.presentation)))
+
+(defclass standard-presentation-effective-slot
+    (ucw::standard-component-effective-slot)
+  ((presentation :accessor presentation-slot.presentation)))
+
+(defmethod mopp:validate-superclass ((class      standard-presentation-class)
+                                     (superclass mopp:standard-class))
+  t)
+
+(flet ((initialize-after (presentation-class)
+	 (setf (presentation-slots presentation-class) nil)
+	 (dolist (slot (mopp:class-slots presentation-class))
+	   (if (and (typep slot 'standard-presentation-effective-slot)
+		    (slot-boundp slot 'presentation))
+	       (push (mopp:slot-definition-name slot)
+		     (presentation-slots presentation-class))))))
+  (defmethod initialize-instance :after
+      ((class standard-presentation-class) &key &allow-other-keys)
+    (if (mopp:class-finalized-p class)
+	(initialize-after class)))
+  (defmethod reinitialize-instance :after
+      ((class standard-presentation-class) &key &allow-other-keys)
+    (if (mopp:class-finalized-p class)
+	(initialize-after class)))
+  (defmethod mopp:finalize-inheritance :after
+      ((class standard-presentation-class))
+    (initialize-after class)))
+
+(defmethod initialize-instance :after
+    ((instance standard-presentation-direct-slot) &key &allow-other-keys)
+  (flet ((presentation-slot->component-slot (slot)
+	   (cond ((null slot) nil)
+		 ((listp slot)
+		  `(,(find-slot-presentation-class-name (car slot)) ,@(cdr slot)))
+		 (t (find-slot-presentation-class-name slot)))))
+    (if (slot-boundp instance 'presentation)
+	(setf (ucw::component-slot.component instance)
+	      (presentation-slot->component-slot (presentation-slot.presentation
+						  instance))))))
+
+(defmethod mopp:direct-slot-definition-class ((class standard-presentation-class)
+                                              &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'standard-presentation-direct-slot))
+
+(defmethod mopp:effective-slot-definition-class ((class standard-presentation-class)
+                                                 &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'standard-presentation-effective-slot))
+
+;; If effective slot is a presentation slot then add a reference to it
+;; to presentation-slots
+
+(defmethod mopp:compute-effective-slot-definition
+    ((class standard-presentation-class)
+     slot-name
+     direct-slot-definitions)
+  (let ((effective-slot (call-next-method)))
+    (flet ((first-specifying-slot (slot-name)
+             "Returns the first STANDARD-COMPONENT-DIRECT-SLOT
+             slot in direct-slot-definitions with a slot named
+             SLOT-NAME bound."
+             (dolist (slot direct-slot-definitions)
+               (when (and (typep slot 'standard-presentation-direct-slot)
+                          (slot-boundp slot slot-name))
+                 (return slot)))))
+      ;; check if slot is a presentation slot
+      (when-bind slot (first-specifying-slot 'presentation)
+        (let ((presentation-spec (slot-value slot 'presentation)))
+	  ;; ensure that the presentation spec is bound in the
+	  ;; effective slot
+          (setf (presentation-slot.presentation effective-slot)
+		presentation-spec)))
+      effective-slot)))
+
+;; Move to presentations.lisp later
+
+(defclass standard-presentation (standard-component)
+  ((css-class :accessor css-class :initarg :css-class :initform nil))
+  (:metaclass standard-presentation-class))
+
+(defmethod presentation-slots ((presentation standard-presentation))
+  (mapcar #'(lambda (slot-name)
+	      (slot-value presentation slot-name))
+	  (presentation-slots (class-of presentation))))
hunk ./ucw-presentations.asd 18
-                 (:file "presentations" :depends-on ("packages"))
+		 (:file "standard-presentation-class" :depends-on ("packages"))
+                 (:file "presentations"
+		  :depends-on ("packages"
+			       "standard-presentation-class"))
}