removing historical implementation
[clinton/lisp-on-lines.git] / src / mewa.lisp
index 98c8135..ca40f24 100644 (file)
@@ -1,61 +1,18 @@
-(declaim (optimize (speed 2) (space 3) (safety 0)))
-
 (in-package :lisp-on-lines)
 
-(defparameter *default-type* :ucw)
-
-(define-layered-class description ()
-  ((description-type
-    :initarg :type
-    :accessor description.type
-    :initform 'viewer
-    :special t)
-   (description-layers
-    :initarg :layers
-    :accessor description.layers
-    :initform nil
-    :special t)
-   (description-properties
-    :accessor description.properties
-    :initform nil
-    :special t)
-   (described-object
-    :layered-accessor object
-    :initform nil
-    :special t)
-   (description-attributes
-    :accessor attributes
-    :initarg :attributes
-    :initform nil
-    :special t)))
-
-(defmethod print-object ((self description) stream)
-  (print-unreadable-object (self stream :type t)
-    (with-slots (description-type) self
-      (format t "~A" description-type))))
-
 ;;;; * Occurences
+;;;; Occurences can be thought of as the class of a description. 
+;;;; Most of the occurence stuff is depreciated now.
 
-(defvar *occurence-map* (make-hash-table)
-  "a display is generated by associating an 'occurence' 
-with an instance of a class. This is usually keyed off class-name,
-although an arbitrary occurence can be used with an arbitrary class.")
-
-(define-layered-class
-    standard-occurence (description)
-    ((attribute-map :accessor attribute-map :initform (make-hash-table)))
-    (:documentation
      "an occurence holds the attributes like a class holds slot-definitions.
-Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
+Attributes are the yetadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."
 
 (defun find-or-create-occurence (name)
   "Returns the occurence associated with this name."
-  (let ((occurence (gethash name *occurence-map*)))
-    (if occurence
-       occurence
-       (let ((new-occurence (make-instance 'standard-occurence)))
-         (setf (gethash name *occurence-map*) new-occurence)
-         new-occurence))))
+  (let ((description (find-description name)))
+    (if description
+       (class-of description)
+       (class-of (ensure-description name)))))
 
 (defun clear-occurence (occurence)
   "removes all attributes from the occurence"
@@ -67,39 +24,78 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
   (:method ((name symbol))
     (find-or-create-occurence name))
   (:method ((instance standard-object))
-    (find-or-create-occurence (class-name (class-of instance)))))
+    (multiple-value-bind (occ new?)
+       (find-or-create-occurence (class-name-of instance))
+      (if new?
+         (initialize-occurence-for-instance occ instance)
+         occ))))
+
+(defun list-attributes (occurence)
+  (let (res)
+    (maphash (lambda (k v)
+              (declare (ignore v))
+              (push k res))
+            (attribute-map occurence))
+    res))
+
+
+(defmethod make-attribute-using-slot-definition (slotd)
+  (make-attribute
+   :name (closer-mop:slot-definition-name slotd)
+   :type-spec (closer-mop:slot-definition-type slotd)
+   :type (first (remove-if (lambda (item)
+                            (or
+                             (eql item 'or)
+                             (eql item 'null)
+                             (eql item nil)))
+                          (ensure-list (closer-mop:slot-definition-type slotd))))))
+
+(defmethod initialize-occurence-for-instance (occurence instance)
+  (let ((slots (closer-mop:class-slots (class-of instance))))
+    (dolist (s slots)
+      (let ((att (make-attribute-using-slot-definition s)))
+       (setf (find-attribute occurence (attribute-name att)) att)))
+    occurence))
+
+
 
 
+;;;; * Attributes
+
 (define-layered-class
     attribute (description)
-    ((attribute-name :layered-accessor attribute.name
+    ((attribute-name :layered-accessor attribute-name
           :initarg :name
           :initform (gensym "ATTRIBUTE-")
           :special t)
      (occurence :accessor occurence :initarg :occurence :initform nil)
      (label :initarg :label :layered-accessor label :initform nil :special t)))
 
-;;;; * Attributes
+
 (defmethod print-object ((self attribute) stream)
   (print-unreadable-object (self stream :type t)
-    (with-slots (name description-type) self
-      (format stream "~A ~A" description-type name))))
+    (with-slots (attribute-name description-type) self
+      (format stream "~A ~A" description-type attribute-name))))
 
 (define-layered-class
     standard-attribute (attribute)
     ((setter :accessor setter :initarg :setter :special t :initform nil)
      (getter :accessor getter :initarg :getter :special t :initform nil)
-     (slot-name :accessor slot-name :initarg :slot-name :special t)
-     (id :accessor id :initarg :id :special t :initform (random-string)))
+     (value :accessor value :initarg :value :special t)
+     (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil)
+     (typespec :accessor type-spec :initarg :type-spec :initform nil))
     (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
 
+(define-layered-method label :around ((attribute standard-attribute))
+ (or (call-next-method) (attribute-name attribute)))
+
 (defmacro defattribute (name supers slots &rest args)
   (let* (
        (type-provided-p (second (assoc :type-name args)))
        (type (or type-provided-p name))
        (layer (or (second (assoc :in-layer args)) nil))
        (properties (cdr (assoc :default-properties args)))
-       (cargs  (remove-if #'(lambda (key)
+       (cargs (remove-if #'(lambda (key)
                   (or (eql key :type-name)
                       (eql key :default-properties)
                       (eql key :default-initargs)
@@ -118,16 +114,12 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
          (:default-initargs :properties (list ,@properties)
            ,@ (cdr (assoc :default-initargs args))))
 
-      ,(unless (not type-provided-p)
-       `(defmethod find-attribute-class-for-type ((type (eql ',type)))
+      ,(when (or
+            type-provided-p
+            (not (find-attribute-class-for-type name)))
+        `(defmethod find-attribute-class-for-type ((type (eql ',type)))
           ',name)))))
 
-(define-layered-class
-    display-attribute (attribute)
-    ()
-    (:documentation "Presentation Attributes are used to display objects 
-using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
-
 (defun clear-attributes (name)
   "removes all attributes from an occurance"
   (clear-occurence (find-occurence name)))
@@ -135,31 +127,40 @@ using the attributes defined in an occurence. Presentation Attributes are always
 (defmethod find-attribute-class-for-type (type)
   nil)
 
-(defmethod find-attribute-class-for-name (name)
-  "presentation attributes are named using keywords"
-  (if (keywordp name)
-      'display-attribute
-      'standard-attribute))
-
-(defun make-attribute (&rest args &key name type &allow-other-keys)
+(defun make-attribute (&rest args &key type &allow-other-keys)
   (apply #'make-instance
         (or (find-attribute-class-for-type type)
-            (find-attribute-class-for-name name))
+            'standard-attribute)
+        :properties args
         args)) 
 
-(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
+(defmethod ensure-attribute ((occurence description) &rest args &key name &allow-other-keys)
   "Creates an attribute in the given occurence"
   (let ((attribute (apply #'make-attribute :occurence occurence args)))
-    (setf (description.properties attribute) args)
-    (setf (gethash name (attribute-map occurence))
-         attribute)))
+    (setf (find-attribute occurence name) attribute)))
 
-(defmethod find-attribute ((occurence standard-occurence) name)
-  (gethash name (attribute-map occurence)))
+(defmethod find-attribute ((occurence null) name)
+  nil)
 
-(defmethod find-all-attributes ((occurence standard-occurence))
+(defmethod find-attribute ((occurence description) name)
+  (or (gethash name (attribute-map occurence))
+      (let* ((class (ignore-errors (find-class (name occurence))))
+            (class-direct-superclasses
+             (when class
+               (closer-mop:class-direct-superclasses
+                class))))
+       (when class-direct-superclasses 
+         (let ((attribute
+                (find-attribute
+                 (find-occurence (class-name
+                                  (car
+                                   class-direct-superclasses)))
+                 name)))
+           attribute)))))
+
+(defmethod find-all-attributes ((occurence description))
   (loop for att being the hash-values of (attribute-map occurence)
-       collect att))
+     collect att))
 
 (defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
   (declare (ignore name type))
@@ -182,15 +183,26 @@ using the attributes defined in an occurence. Presentation Attributes are always
 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
   (apply #'ensure-attribute occurence-name :name attribute-name :type (first attribute-spec) (rest attribute-spec)))
 
+(defmethod (setf find-attribute) ((attribute standard-attribute) occurence attribute-name)
+  "Create a new attribute in the occurence.
+ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
+  (setf (gethash attribute-name (attribute-map occurence))
+         attribute))
+
+(defmethod (setf find-attribute) ((attribute null) occurence attribute-name)
+  "Create a new attribute in the occurence.
+ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
+  (setf (gethash attribute-name (attribute-map occurence))
+         attribute))
 
 (defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
   (find-attribute (occurence attribute-with-occurence) attribute-name))
 
 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
-  (setf (description.properties attribute) (plist-nunion
+  (setf (description-properties attribute) (plist-nunion
                                            properties
-                                           (description.properties attribute)))
-  (loop for (initarg value) on (description.properties attribute) 
+                                           (description-properties attribute)))
+  (loop for (initarg value) on (description-properties attribute) 
              by #'cddr
              with map = (initargs.slot-names attribute)
              do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map)))
@@ -208,14 +220,14 @@ ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
 otherwise, (setf find-attribute)"
   (let ((att (find-attribute occurence-name attribute-name)))
     (if (and att inherit (or (eql (car attribute-spec)
-                             (description.type att))
+                             (description-type att))
                             (eq (car attribute-spec) t)))
        (set-attribute-properties occurence-name att (cdr attribute-spec))
        (setf (find-attribute occurence-name attribute-name)
              (cons  (car attribute-spec)
                     (plist-nunion
                      (cdr attribute-spec) 
-                     (when att (description.properties att))))))))
+                     (when att (description-properties att))))))))
 
 (defmethod perform-define-attributes ((occurence-name t) attributes)
   (loop for attribute in attributes
@@ -230,20 +242,14 @@ otherwise, (setf find-attribute)"
     ,@(loop for occurence-name in occurence-names
            collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
 
-(defmethod find-display-attribute (occurence name)
-  (find-attribute occurence (intern (symbol-name name) "KEYWORD")))
 
-(defmethod find-description (object type)
-  (let ((occurence (find-occurence object)))
-    (or (find-display-attribute
-        occurence
-        type)
-       occurence)))
 
+
+;;"Unused???"
 (defmethod setter (attribute)
   (warn "Setting ~A in ~A" attribute *context*)
-  (let ((setter (getf (description.properties attribute) :setter))
-       (slot-name (getf (description.properties attribute) :slot-name)))
+  (let ((setter (getf (description-properties attribute) :setter))
+       (slot-name (getf (description-properties attribute) :slot-name)))
     (cond (setter
           setter)
          (slot-name
@@ -257,16 +263,40 @@ otherwise, (setf find-attribute)"
 (define-layered-function attribute-value (instance attribute)
   (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
 
+(defmethod attribute-slot-value (instance attribute)
+  "Return (VALUES slot-value-or-nil existsp boundp
+
+If this attribute, in its current context, refers to a slot,
+we return slot-value-or nil either boundp or not."
+  (let (existsp boundp slot-value-or-nil)
+    (cond 
+      ((and (slot-boundp attribute 'slot-name) (slot-name attribute))
+        (when (slot-exists-p instance (slot-name attribute))
+          (setf existsp t)
+          (when (slot-boundp instance (slot-name attribute))
+            (setf boundp t
+                  slot-value-or-nil (slot-value
+                                     instance
+                                     (slot-name attribute))))))
+       ((and (slot-exists-p instance (attribute-name attribute)))
+        (setf existsp t)
+        (when (slot-boundp instance (attribute-name attribute))
+          (setf boundp t
+                slot-value-or-nil (slot-value
+                                   instance
+                                   (attribute-name attribute))))))
+    (VALUES slot-value-or-nil existsp boundp)))
+  
 (define-layered-method attribute-value (instance (attribute standard-attribute))
-    (with-slots (getter slot-name) attribute 
-      (cond ((and (slot-boundp attribute 'getter) getter) 
-            (funcall getter instance))
-           ((and (slot-boundp attribute 'slot-name) slot-name)
-            (when (slot-boundp instance slot-name)
-                (slot-value instance slot-name)))
-           ((and (slot-exists-p instance (attribute.name attribute)) )
-              (when (slot-boundp instance (attribute.name attribute))
-                (slot-value instance (attribute.name attribute)))))))
+ "return the attribute value or NIL if it cannot be found"                    
+    (with-slots (getter value) attribute
+      (when (slot-boundp attribute 'value)
+       (setf getter (constantly value)))
+      (if (and (slot-boundp attribute 'getter) getter)
+         ;;;; call the getter
+         (funcall getter instance)
+         ;;;; or default to the attribute-slot-value
+         (attribute-slot-value instance attribute))))
 
 (define-layered-function (setf attribute-value) (value instance attribute))
 
@@ -274,20 +304,19 @@ otherwise, (setf find-attribute)"
     (setf attribute-value) (value instance (attribute standard-attribute))
   (with-slots (setter slot-name) attribute 
     (cond ((and (slot-boundp attribute 'setter) setter)
-
           (funcall setter value instance))
          ((and (slot-boundp attribute 'slot-name) slot-name)
           (setf (slot-value instance slot-name) value))
-         ((and (slot-exists-p instance (attribute.name attribute)) slot-name)
-          (setf (slot-value instance (attribute.name attribute)) value))
+         ((and (slot-exists-p instance (attribute-name attribute)))
+          (setf (slot-value instance (attribute-name attribute)) value))
          (t
           (error "Cannot set ~A in ~A" attribute instance)))))
 
 
 
 ;;;; ** Default Attributes
-
-
+;;;; TODO: This is mosty an ugly hack and should be reworked.
+;;;; 
 ;;;; The default mewa class contains the types use as defaults.
 ;;;; maps meta-model slot-types to slot-presentation
 
@@ -298,48 +327,31 @@ otherwise, (setf find-attribute)"
     ,@body))
 
 (define-attributes (default)
-  (boolean mewa-boolean)
-  (string mewa-string)
-  (number mewa-currency)
-  (integer   mewa-integer)
-  (currency  mewa-currency)
-  (clsql:generalized-boolean mewa-boolean)
-  (foreign-key foreign-key)
-  (:viewer mewa-viewer)
-  (:editor mewa-editor)
-  (:creator mewa-creator)
-  (:as-string mewa-one-line-presentation)
-  (:one-line mewa-one-line-presentation)
-  (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t)
-  (:search-model mewa-object-presentation))
-
-(defun find-presentation-attributes (occurence-name)
-  (loop for att in (find-all-attributes occurence-name)
-       when (typep att 'display-attribute)
-        collect att))
+  (boolean boolean)
+  (string string)
+  (number currency)
+  (integer   integer)
+  (currency  currency)
+  (clsql:generalized-boolean boolean)
+  (foreign-key has-a))
 
 (defun attribute-to-definition (attribute)
-  (nconc (list (attribute.name attribute)
-              (description.type attribute))
-        (description.properties attribute)))
+  (nconc (list (attribute-name attribute)
+              (description-type attribute))
+        (description-properties attribute)))
 
 (defun find-default-presentation-attribute-definitions ()
-  (if (eql *default-attributes-class-name* 'default)
-      (mapcar #'attribute-to-definition (find-presentation-attributes 'default)) 
-      (remove-duplicates (mapcar #'attribute-to-definition
-                                (append
-                                 (find-presentation-attributes 'default)
-                                 (find-presentation-attributes
-                                  *default-attributes-class-name*))))))
+  nil)
+
 (defun gen-ptype (type)
   (let* ((type (if (consp type) (car type) type))
         (possible-default (find-attribute *default-attributes-class-name* type))
         (real-default (find-attribute 'default type)))
     (cond
       (possible-default
-       (description.type possible-default))
+       (description-type possible-default))
        (real-default
-       (description.type real-default))
+       (description-type real-default))
        (t type))))
 
 (defun gen-presentation-slots (instance)
@@ -355,8 +367,3 @@ otherwise, (setf find-attribute)"
               :slot-name ,slot-name))) 
 
 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
-;; You are granted the rights to distribute
-;; and use this software as governed by the terms
-;; of the Lisp Lesser GNU Public License
-;; (http://opensource.franz.com/preamble.html),
-;; known as the LLGPL.