added ROFL test cases + extra formatting hooks for attributes
[clinton/lisp-on-lines.git] / src / description-class.lisp
dissimilarity index 97%
index 9bf31e0..fb6e7ff 100644 (file)
-(in-package :lisp-on-lines)
-
-;;; * The Description Meta-Meta-Super class.
-
-(defclass description-special-layered-access-class 
-    (contextl::special-layered-access-class)
- ((original-name :initarg original-name)
-  (description-layer :initarg description-layer)
-  (instance)))
-          
-(defmethod closer-mop:direct-slot-definition-class 
-    ((class description-special-layered-access-class) 
-     &key &allow-other-keys)
-  (find-class 'attribute-special-layered-direct-slot-definition))
-
-(defmethod closer-mop:effective-slot-definition-class 
-    ((class description-special-layered-access-class) 
-     &key name &allow-other-keys)
-    (declare (ignore name))
-  (find-class 'standard-attribute))
-
-(defmethod closer-mop:compute-effective-slot-definition :around
-    ((class description-special-layered-access-class) name direct-slot-definitions)
-  (declare (ignore name))
-  (let ((slotd (call-next-method)))
-    (setf (slot-value slotd 'direct-slots) direct-slot-definitions)
-    
-    (apply #'shared-initialize slotd nil (slot-value 
-                                         (find t direct-slot-definitions 
-                                               :test #'eq 
-                                               :key #'slot-definition-layer )
-                                         'initargs))
-
-    slotd))
-                                                  
-;;; * The Description Meta-Meta class.
-(defclass description-class (description-special-layered-access-class layered-class) 
-  ()
-  (:default-initargs :defining-metaclass 'description-special-layered-access-class))
-
-(defun initialize-description-class (class)
-  (let ((description (make-instance class)))
-    (setf (slot-value class 'instance) description)
-    (dolist (slotd (closer-mop:class-slots class))
-      (setf (slot-value slotd 'description) description)
-      (dolist (slot (slot-value slotd 'direct-slots))
-       (setf (slot-value slot 'initargs) 
-             (loop 
-                :for (initarg value) 
-                :on (slot-value slot 'initargs)
-                :by #'cddr
-                :nconc (list initarg
-                             (if (eval-attribute-initarg slotd initarg)
-                                 (eval value)
-                                 value))))
-       (ensure-layered-method  
-        'special-slot-values
-        `(lambda (description attribute)
-           (list ,@(loop 
-                :for (initarg value) 
-                :on (slot-value slot 'initargs)
-                :by #'cddr
-                :nconc (list (list 'quote (or (find-slot-name-from-initarg 
-                                  (class-of slotd) initarg) initarg))
-                             
-                                 value))))
-        :in-layer (slot-definition-layer slot) 
-        :qualifiers '(append)
-        :specializers (list class (closer-mop:intern-eql-specializer (closer-mop:slot-definition-name slotd))))))))
-
-(defmethod closer-mop:finalize-inheritance :after ((class description-class))
-  (initialize-description-class class))
-
-(define-layered-class description ()
-  ((identity :function #'identity))
-  (:metaclass description-class)
-  (description-layer t))
-
-(eval-when (:load-toplevel :execute)
- (closer-mop:finalize-inheritance (find-class 'description)))
-
-;;; The layer itself. 
-#+nil(deflayer description ()
-  ()
-  (:metaclass description))
-
-#+nil (defmethod print-object ((object description) stream)
-  (call-next-method))
-
-(defgeneric find-description-class (name &optional errorp)        
-  ;; !-- Sometimes it gets inited, sometimes it don't.
-  (:method :around (name &optional errorp)
-          (let ((class (call-next-method)))
-            (unless (slot-boundp class 'instance)
-              (initialize-description-class class)) 
-            class))
-  (:method ((name (eql t)) &optional errorp)
-    (declare (ignore errorp))
-    (find-class 'description t))
-  (:method ((name symbol) &optional errorp)
-    (or (find-class (defining-description name) errorp)
-       (find-description-class t)))
-  (:method ((description description) &optional errorp)
-    (declare (ignore errorp))
-    (class-of description)))
-
-;;; A handy macro.
-(defmacro define-description (name &optional superdescriptions &body options)
-  (let ((description-name (defining-description name)))
-     
-    (destructuring-bind (&optional slots &rest options) options
-      `(prog1
-          (defclass ,description-name ,(append (mapcar #'defining-description superdescriptions) '(description))
-            ,(if slots slots '())
-            ,@options
-            ,@(unless (assoc :metaclass options)
-                      '((:metaclass description-class)))
-            (original-name . ,name))
-        (initialize-description-class (find-description-class ',description-name))))))
-
-
-
+(in-package :lisp-on-lines)
+
+;;;; * DESCRIPTIONS
+;;;; A description is an object which is used 
+;;;; to describe another object.
+
+
+;;; #+HACK
+;;; I'm having some 'issues' with 
+;;; compiled code and my initialization.
+;;; So this hack initializes the world.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *defined-descriptions* nil))
+
+(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
+  ((defined-in-descriptions :initarg :in-description)
+   (mixin-class-p :initarg :mixinp)))
+
+(defmethod direct-slot-definition-class
+           ((class description-access-class) &key &allow-other-keys)
+  (find-class 'direct-attribute-definition-class))
+
+(defmethod effective-slot-definition-class
+           ((class description-access-class) &key &allow-other-keys)
+  (find-class 'effective-attribute-definition-class))
+
+(defmethod compute-effective-slot-definition
+           ((class description-access-class) name direct-slot-definitions)
+  (declare (ignore name))
+  (let ((attribute (call-next-method)))
+    (setf (attribute-direct-attributes attribute) direct-slot-definitions)
+    (setf (attribute-object-initargs attribute)  
+         ;; This plist will be used to init the attribute object
+          ;; Once the description itself is properly initiated.
+         (list :name name 
+               'effective-attribute attribute))
+    attribute))
+
+(defmethod slot-value-using-class ((class description-access-class) object slotd)
+        (call-next-method)
+#+nil  (if (or 
+       (eq (slot-definition-name slotd) 'described-object)
+       (not (slot-boundp slotd 'attribute-object)))
+      (call-next-method)
+      (slot-definition-attribute-object slotd)))
+    
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *description-attributes* (make-hash-table)))
+
+
+
+(defclass standard-description-class (description-access-class layered-class)
+  ((attributes :accessor description-class-attributes :initform (list)))
+  (:default-initargs :defining-metaclass 'description-access-class))
+
+
+
+(defmethod validate-superclass
+           ((class standard-description-class)
+            (superclass standard-class))
+  t)
+
+(define-layered-class standard-description-object (standard-layer-object) 
+  ((described-object :accessor described-object 
+                    :special t)))
+
+(defun description-class-name  (description-class)
+    (read-from-string (symbol-name (class-name description-class))))
+
+(defgeneric standard-description-p (description-candidate)
+  (:method (not-description)
+    NIL)
+  (:method ((description standard-description-object))
+    T))
+  
+(defun initialize-description-class (class)
+
+;;; HACK: initialization does not happ   en properly 
+;;; when compiling and loading or something like that.
+;;; Obviously i'm not sure why.
+;;; So we're going to explicitly initialize things.
+;;; For now. --drewc
+
+  (pushnew class *defined-descriptions*)
+
+;;; ENDHACK.
+  
+  (let* ((description (find-layer class)) 
+        (attribute-objects 
+         (setf (description-class-attributes (class-of description))
+               (mapcar 
+                (lambda (slot)
+                  (or (find-attribute description 
+                                      (slot-definition-name slot))
+                      (let* ((*init-time-description* description)
+                             (attribute-class (or 
+                                               (ignore-errors 
+                                                 (slot-value-using-class 
+                                                  (class-of description) description slot))
+                                               'standard-attribute))
+                             (attribute                     
+                              (apply #'make-instance 
+                                     attribute-class
+                                     :description description
+                                     :attribute-class attribute-class
+                                     (attribute-object-initargs slot))))
+                        (setf (slot-definition-attribute-object slot) attribute))))
+                (remove 'described-object (class-slots (class-of description))
+                        :key #'slot-definition-name))))
+        (defining-classes 
+         (partial-class-defining-classes class)))
+
+    (loop 
+       :for (layer class) 
+       :on  defining-classes :by #'cddr 
+       :do (funcall-with-layer-context 
+           (adjoin-layer (find-layer layer) (current-layer-context))
+           (lambda ()
+             (loop :for direct-slot :in (class-direct-slots class) 
+                :do (let ((attribute 
+                           (find (slot-definition-name direct-slot) 
+                                 attribute-objects 
+                                 :key #'attribute-name)))
+                      (let ((initargs 
+                             (prepare-initargs attribute (direct-attribute-properties direct-slot))))
+                        
+                        (apply #'reinitialize-instance attribute 
+                               initargs )
+                        (setf (slot-value description (attribute-name attribute)) 
+                              (attribute-class attribute))
+                        (apply #'change-class attribute  (attribute-class attribute)
+                               initargs)))))))))
+
+
+#+old(defun initialize-description-class (class)
+
+;;; HACK: initialization does not happ   en properly 
+;;; when compiling and loading or something like that.
+;;; Obviously i'm not sure why.
+;;; So we're going to explicitly initialize things.
+;;; For now. --drewc
+
+  (pushnew class *defined-descriptions*)
+
+;;; ENDHACK.
+
+  (let* ((description (find-layer class)) 
+        (attribute-objects 
+         (mapcar 
+          (lambda (slot)
+            (let* ((*init-time-description* description)
+                         (attribute                 
+                          (apply #'make-instance 
+                           'standard-attribute
+                           :description description
+                           (attribute-object-initargs slot))))
+              
+                    
+              (setf (slot-definition-attribute-object slot) attribute)))
+          (remove 'described-object (class-slots (class-of description))
+                  :key #'slot-definition-name)))
+        (defining-classes (partial-class-defining-classes (class-of description))))
+
+    (loop 
+       :for (layer class) 
+       :on  defining-classes :by #'cddr 
+       :do (funcall-with-layer-context 
+           (adjoin-layer (find-layer layer) (current-layer-context))
+           (lambda ()
+             (loop :for direct-slot :in (class-direct-slots class) 
+                :do (let ((attribute 
+                           (find (slot-definition-name direct-slot) 
+                                 attribute-objects 
+                                 :key #'attribute-name)))
+                      (let ((initargs 
+                             (prepare-initargs attribute (direct-attribute-properties direct-slot))))
+                        
+                        (apply #'reinitialize-instance attribute 
+                               initargs )
+                        (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))
+                        (when (not (eq (find-class (attribute-class attribute))
+                                       (class-of attribute)))
+                          (warn "~%CHANGING CLASS~%")
+                          
+                          (apply #'change-class attribute  (attribute-class attribute) 
+                                 initargs))))))))))
+
+;;;; HACK: run this at startup till we figure things out.
+(defun initialize-descriptions () 
+  (map nil #'initialize-description-class 
+       (setf *defined-descriptions* 
+            (remove-duplicates *defined-descriptions*))))
+
+(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
+  (declare (dynamic-extent initargs))
+  (prog1
+      (if (loop for direct-superclass in direct-superclasses
+               thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
+       (call-next-method)
+       (apply #'call-next-method
+              class
+              :direct-superclasses
+              (append direct-superclasses
+                      (list (find-class 'standard-description-object)))
+              initargs))
+    (initialize-description-class class)))
+
+
+(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+  (declare (dynamic-extent initargs))
+;  (warn "CLASS ~A ARGS ~A:" class initargs)
+  (prog1
+      (if (or (not direct-superclasses-p)
+               (loop for direct-superclass in direct-superclasses
+                     thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
+         (call-next-method)
+         (apply #'call-next-method
+                class
+                :direct-superclasses
+                (append direct-superclasses
+                        (list (find-class 'standard-description-object)))
+                initargs))
+    (initialize-description-class class)))
+                     
+                     
+(defmethod print-object ((object standard-description-object) stream)
+  (print-unreadable-object (object stream :type nil :identity t)
+    (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
+
+(defmethod print-object ((object standard-description-class) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (princ  (ignore-errors (description-print-name (find-layer object))) stream)))
+
+(defun find-description (name)
+  (find-layer (find-class (defining-description name))))
+
+
+
+
+
+