X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/81d7061052c90867a26b50e69e35f5d96b17686a..e8fd1a9a2f3b68a8aee14b8776ff8398ba717eef:/src/attribute.lisp

diff --git a/src/attribute.lisp b/src/attribute.lisp
dissimilarity index 83%
index 6d47657..7273260 100644
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -1,222 +1,343 @@
-(in-package :lisp-on-lines)
-
-(define-layered-class direct-attribute-definition-class 
- (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition)
-  ((attribute-properties :accessor direct-attribute-properties
-		     :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition.")))
-
-(defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs)
-  (setf (direct-attribute-properties attribute) initargs))
-
-(define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) 
-  ((direct-attributes :accessor attribute-direct-attributes)
-   (attribute-object :accessor attribute-object
-		     :documentation "")
-   (attribute-object-initargs :accessor attribute-object-initargs)))
-
-
-(define-layered-function attribute-value (object attribute))
-
-(define-layered-method attribute-value (object attribute)
-		       
- (let ((fn (handler-case (attribute-function attribute)
-	     (unbound-slot () nil))))
-   (if fn 
-       (funcall fn object)
-       (%attribute-value attribute))))
-
-(defmethod attribute-description (attribute)
-  ;(break "description for ~A is (slot-value attribute 'description-name)")
-  (find-layer (slot-value attribute 'description-class))
-#+nil  (let ((name (slot-value attribute 'description-name)))
-    (when name 
-      (find-description name))))
-
-
-(define-layered-class standard-attribute ()
-		      
-  ((effective-attribute-definition :initarg effective-attribute
-				   :accessor attribute-effective-attribute-definition)
-   (description-name)
-   (description-class :initarg description-class)
-   (initfunctions :initform nil)
-   (attribute-class :accessor attribute-class 
-		    :initarg :attribute-class 
-		    :initform 'standard-attribute)
-   (name :layered-accessor attribute-name 
-	  :initarg :name)
-   (label :layered-accessor attribute-label 
-	  :initarg :label
-	  :initform nil
-	  :layered t
-	  ;:special t
-	  )
-   (function 
-    :initarg :function 
-    :layered-accessor attribute-function
-    :layered t)
-   (value :layered-accessor %attribute-value 
-	  :initarg :value
-	  :layered t)))
-
-
-
-(defmethod print-object ((object standard-attribute) stream)
-  (print-unreadable-object (object stream :type nil :identity t)
-    (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
-
-(defvar *bypass-property-layered-function* nil)
-
-(define-layered-function property-layered-function (description attribute-name property-name)
-  (:method  (description attribute-name property-name)
-    ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name)
-    (ensure-layered-function 
-     (defining-description (intern (format nil "~A-~A-~A" 
-		    (description-print-name description)
-		     attribute-name
-		     property-name)))
-
-     :lambda-list '(description))))
-
-(define-layered-method (setf slot-value-using-layer)
-  :in-layer (context t)
-  (new-value class (attribute standard-attribute) property writer)
-
-  (when (or *bypass-property-layered-function*
-	    (not (slot-definition-layeredp property)))
-    (return-from slot-value-using-layer (call-next-method)))
-
-  
-  ;;FIXME: this is wrong for so many reasons.
-  (let ((layer
-	 (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
-		     :key #'class-name)))))
-
-    
-    (flet ((do-set-slot()
-
-	     (let ((fn 
-	      (let ((*bypass-property-layered-function* t))
-		(if (slot-boundp-using-class class attribute property)
-		    (slot-value-using-class class attribute property)
-		    (setf (slot-value-using-class class attribute property)
-			  (property-layered-function 
-			   (attribute-description attribute)
-			   (attribute-name attribute)
-			   (closer-mop:slot-definition-name property)))))))
-	 ;(dprint "We are setting the fn ~A " fn)
-	 (when (not (generic-function-methods fn))
-	  ; (dprint "... there are no methods on it ever")
-	   ;; * This slot has never been set before.
-	   ;; create a method on property-layered-function
-	   ;; so subclasses can see this new property.
-	   (ensure-layered-method 
-	    (layered-function-definer 'property-layered-function)
-	    `(lambda (description attribute property)
-	       (declare (ignore description attribute property))
-	       ,fn)
-	    :in-layer layer
-	    :specializers  
-	    (list (class-of  
-		   (attribute-description attribute))
-		  (closer-mop:intern-eql-specializer 
-		   (attribute-name attribute))
-		  (closer-mop:intern-eql-specializer 
-		   (closer-mop:slot-definition-name property)))))
-	     
-	   
-	 ;; finally, specialize this property to this description.
-	 (ensure-layered-method 
-	  fn
-	  `(lambda (description)
-	     ,new-value)
-	  :in-layer layer 
-	  :specializers (list (class-of (attribute-description attribute)
-				       ))))))
-      
-      (if (slot-boundp attribute 'description-class)
-	  (do-set-slot)
-	  (push (lambda () (do-set-slot)) 
-		(slot-value attribute 'initfunctions))))))
-
-
-(define-layered-method slot-value-using-layer 
-  :in-layer (layer t)
-  :around (class (attribute standard-attribute) property reader)
-
-  ;;  (dprint "Getting the slot value of ~A" property) 
-  
-  ;; We do some magic in here and i thought it 
-  ;; would be called magically in call-next-method.
-  ;; This explicit call is good enough for now.
-
-  (unless (slot-boundp-using-class class attribute property)
-    (slot-unbound class attribute (slot-definition-name property)))
-
-  (if (and 
-       (contextl::slot-definition-layeredp property)
-       (not *bypass-property-layered-function*))
-      (let ((fn (call-next-method)))
-	;(dprint "... using fn ~A to get value" fn)
-      (funcall fn layer  (attribute-description attribute)))
-      (call-next-method)))
-
-(defmacro define-bypass-function (name function-name)
-  `(defun ,name (&rest args)
-     (let ((*bypass-property-layered-function* t))
-       (apply (function ,function-name) args))))
-
-(define-bypass-function real-slot-boundp-using-class slot-boundp-using-class)
-(define-bypass-function real-slot-value-using-class slot-value-using-class)
-(define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class))
-  
-(defun slot-boundp-using-property-layered-function (class attribute property)
-  (dprint "plf boundp:")
-  (let* ((really-bound-p 
-	  (real-slot-boundp-using-class class attribute property))
-	 (fn (if really-bound-p 
-		 (real-slot-value-using-class class attribute property)
-		 (setf (real-slot-value-using-class class attribute property)
-		       (property-layered-function 
-			(attribute-description attribute)
-			(attribute-name attribute)
-			(closer-mop:slot-definition-name property))))))
-    (dprint "Slot was bound? ~A" really-bound-p)
-    ;; If the slot is unbound, we search for its layered-function
-      (if (generic-function-methods fn)
-	  T
-	  NIL)))
-    
-(define-layered-method slot-boundp-using-layer  
-  :in-layer (layer t)
-  :around (class (attribute standard-attribute) property reader)
-  (if *bypass-property-layered-function*
-      (call-next-method)
-      (slot-boundp-using-property-layered-function class attribute property)))
-        
-(defun attribute-value* (attribute)
-  (attribute-value *object* attribute))
-
-(defmacro with-attributes (names description &body body)
-  `(with-slots ,names ,description ,@body))  
-
-(defun display-attribute (attribute)
-  (display-using-description attribute *display* *object*))
-
-(define-layered-method display-using-description 
-  ((attribute standard-attribute) display object &rest args)
-  (declare (ignore args))
-  (when (attribute-label attribute)
-    (format display "~A " (attribute-label attribute)))
-  (format display "~A" (attribute-value object attribute)))
-
-
-
-
-
-
-
-		       
-	
-
-
+(in-package :lisp-on-lines)
+
+(define-layered-class direct-attribute-definition-class 
+  (special-layered-direct-slot-definition 
+   contextl::singleton-direct-slot-definition)
+  ((attribute-properties 
+    :accessor direct-attribute-properties
+    :documentation "This is an plist to hold the values of 
+    the attribute's properties as described by this direct 
+    attribute definition.")))
+
+(defmethod initialize-instance 
+    :after ((attribute direct-attribute-definition-class) 
+	    &rest initargs)
+  (setf (direct-attribute-properties attribute) initargs))
+
+(define-layered-class effective-attribute-definition-class 
+    (special-layered-effective-slot-definition) 
+  ((direct-attributes 
+    :accessor attribute-direct-attributes)
+   (attribute-object 
+    :accessor slot-definition-attribute-object)
+   (attribute-object-initargs 
+    :accessor attribute-object-initargs)))
+
+(defvar *function-access* nil
+  "set/get a place's property function instead of its symbol value
+   when this is set to a non-nil value")
+
+(defmacro with-function-access (&body body)
+  "executes body in an environment with *function-access* set to t"
+  `(let ((*function-access* t))
+     ,@body))
+
+(defmacro without-function-access (&body body)
+  "executes body in an environment with *function-access* set to nil"
+  `(let ((*function-access* nil))
+     ,@body))
+
+(define-layered-function property-access-function (description attribute-name property-name)
+  (:method  (description attribute-name property-name)
+    (ensure-layered-function 
+     (defining-description 
+	 (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A=" 
+			 (description-print-name description)
+			 attribute-name
+			 property-name)))
+	 :lambda-list '(description))))
+
+
+(defvar *init-time-description* nil)
+
+(defmethod attribute-description :around (attribute)
+  (handler-case (call-next-method)
+    (unbound-slot () 
+      (or 
+       *init-time-description*
+       (call-next-method)))))
+
+(define-layered-class attribute ()
+ ((description :initarg :description 
+	       :accessor attribute-description)
+  (name 
+   :layered-accessor attribute-name 
+   :initarg :name)
+  (effective-attribute-definition 
+    :initarg effective-attribute
+    :accessor attribute-effective-attribute-definition)
+  (attribute-class 
+   :accessor attribute-class 
+   :initarg :attribute-class 
+  :initform 'standard-attribute)
+  (keyword
+   :layered-accessor attribute-keyword
+   :initarg :keyword
+   :initform nil
+   :layered t)
+  (object 
+   :layered-accessor attribute-object
+   :accessor described-object
+   :special t)))
+
+
+(define-layered-class standard-attribute (attribute)
+ ((label 
+   :layered-accessor attribute-label 
+   :initarg :label
+   :initform nil
+   :layered t
+   :special t)
+  (label-formatter 
+   :layered-accessor attribute-label-formatter
+   :initarg :label-formatter
+   :initform  nil 
+   :layered t
+   :special t)
+  (function 
+   :initarg :function 
+   :layered-accessor attribute-function
+   :layered t
+   :special t)
+  (value 
+   :layered-accessor attribute-value 
+   :initarg :value
+   :layered t
+   :special t)
+  (value-formatter 
+   :layered-accessor attribute-value-formatter
+   :initarg :value-formatter
+   :initform nil
+   :layered t
+   :special t)
+  (activep 
+   :layered-accessor attribute-active-p
+   :initarg :activep ;depreciated
+   :initarg :active
+   :initform t
+   :layered t
+   :special t
+   :documentation
+   "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
+  (active-attributes :layered-accessor attribute-active-attributes
+		       :initarg :attributes
+		       :layered t
+		       :special t)
+  (active-descriptions :layered-accessor attribute-active-descriptions
+		       :initarg :activate
+		       :initform nil
+		       :layered t
+		       :special t)
+  (inactive-descriptions :layered-accessor attribute-inactive-descriptions
+		       :initarg :deactivate
+		       :initform nil
+		       :layered t
+		       :special t)))
+
+(define-layered-method attribute-active-p :around (attribute)		       
+ (let ((active? (call-next-method)))
+   (if (eq :when active?)
+       (not (null (attribute-value attribute)))
+       active?)))
+		       
+(define-layered-method attribute-label-formatter :around (attribute)
+   (or (slot-value attribute 'label-formatter) 
+       (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
+       (error "No Formatter .. fool!")))
+
+(define-layered-method attribute-value-formatter :around (attribute)
+		       
+   (or (slot-value attribute 'value-formatter) 
+       (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
+       (error "No Formatter .. fool!")))
+		       
+
+
+(define-layered-method attribute-object ((attribute standard-attribute))
+ (if (slot-boundp attribute 'object)
+     (call-next-method)
+     (described-object (attribute-description attribute))))
+
+
+(define-layered-function attribute-value-using-object (object attribute))
+(define-layered-function (setf attribute-value-using-object) (value object attribute))
+
+(define-layered-method attribute-value ((attribute standard-attribute))
+ (attribute-value-using-object (attribute-object attribute) attribute))
+
+(define-layered-method attribute-value-using-object (object attribute)
+ (let ((fn (handler-case (attribute-function attribute)
+	     (unbound-slot () nil))))
+   (if fn 
+       (funcall fn object)
+       (slot-value attribute 'value))))
+
+(define-layered-method (setf attribute-value) (value (attribute standard-attribute))
+ (setf (attribute-value-using-object (attribute-object attribute) attribute) value))
+
+(define-layered-method (setf attribute-value-using-object) (value object attribute)
+ (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
+	object attribute))
+
+
+(defun ensure-access-function (class attribute property)
+  (with-function-access 
+    (if (slot-definition-specialp property)
+	(let ((slot-symbol 
+	       (with-symbol-access
+		 (slot-value-using-class 
+		  class attribute property))))
+	  (if (fboundp slot-symbol)
+	      (symbol-function slot-symbol)
+	      (setf (symbol-function slot-symbol)
+		    (property-access-function
+		     (attribute-description attribute)
+		     (attribute-name attribute)
+		     (slot-definition-name property)))))
+	(if (slot-boundp-using-class class attribute property)
+	    (slot-value-using-class class attribute property)
+	    (setf (slot-value-using-class class attribute property)
+		  (property-access-function
+		   (attribute-description attribute)
+		   (attribute-name attribute)
+		   (slot-definition-name property)))))))
+
+(define-layered-method slot-boundp-using-layer  
+  :in-layer (layer t)
+  :around (class (attribute standard-attribute) property reader)
+
+; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
+	; (slot-definition-name property))
+
+  (if (or *symbol-access* *function-access*)
+      (call-next-method)
+      (or (when (slot-definition-specialp property)
+	    (with-function-access
+	   (slot-boundp-using-class class attribute property)))
+	  (if (generic-function-methods 
+	       (ensure-access-function class attribute property))
+	      T
+	      NIL))))
+
+(define-layered-method (setf slot-value-using-layer)
+  :in-layer (context t)
+  :around
+  (new-value class (attribute standard-attribute) property writer)
+  
+;;  (dprint "Setting ~A ~A to : ~A" attribute property new-value)
+
+  (if (or *symbol-access* *function-access*)
+      (call-next-method)
+	     
+      (if (and (slot-definition-specialp property)
+	       (with-function-access
+		 (without-symbol-access (slot-boundp-using-class class attribute property))))
+	  (with-function-access
+	    (call-next-method))
+	  (let ((layer
+		 ;;FIXME: this is wrong for so many reasons
+		 (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
+					    :key #'class-name))))
+		(boundp (slot-boundp-using-class class attribute property))
+		(fn  (ensure-access-function class attribute property)))
+
+	    (when (not boundp)
+	      ;; * This slot has never been set before.
+	      ;; create a method on property-accessor-function
+	      ;; so subclasses can see this new property.
+	      (ensure-layered-method 
+	       (layered-function-definer 'property-access-function)
+	       `(lambda (description attribute property)
+		  (declare (ignore description attribute property))
+		  ,fn)
+	       :in-layer layer
+	       :specializers  
+	       (list (class-of  
+		      (attribute-description attribute))
+		     (closer-mop:intern-eql-specializer 
+		      (attribute-name attribute))
+		     (closer-mop:intern-eql-specializer 
+		      (closer-mop:slot-definition-name property)))))
+
+	    ;; specialize this property to this description.
+	    ;;(dprint "actrually specializering")
+	    (ensure-layered-method 
+	     fn
+	     `(lambda (description)
+		(funcall ,(lambda()
+				 new-value)))
+	     :in-layer layer 
+	     :specializers (list (class-of (attribute-description attribute))))
+
+	    ;;	and return the set value as is custom
+	    new-value))))
+		      
+(define-layered-method slot-value-using-layer 
+  :in-layer (layer t)
+  :around (class (attribute standard-attribute) property reader)
+  
+;  ;(dprint "Getting the slot value of ~A" property)   
+  (if (or *symbol-access* *function-access*)
+      (call-next-method)
+      (let ((fn (ensure-access-function class attribute property)))
+
+	(unless (slot-boundp-using-class class attribute property)
+	  (slot-unbound class attribute (slot-definition-name property)))
+
+	(if (slot-definition-specialp property)
+	    (if (with-function-access
+		  (slot-boundp-using-class class attribute property))
+		(with-function-access 
+		  (slot-value-using-class class attribute property))
+		(funcall fn layer (attribute-description attribute)))
+	    (handler-case (funcall fn layer (attribute-description attribute))
+	      (error ()
+		(warn "Error calling ~A" fn)))))))
+		    
+	      
+
+
+
+
+(defmethod print-object ((object standard-attribute) stream)
+  (print-unreadable-object (object stream :type nil :identity t)
+    (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
+
+(defgeneric eval-property-initarg (att initarg)
+  (:method ((attribute standard-attribute) initarg)
+    nil)
+  (:method ((attribute standard-attribute) (initarg (eql :function)))
+    t)
+  (:method ((attribute standard-attribute) (initarg (eql :value)))
+    t))
+
+(defun prepare-initargs (att args)
+  (loop 
+     :for (key arg) 
+     :on args :by #'cddr 
+     :nconc (list key 
+		  (if (eval-property-initarg att key)
+		      (eval arg)
+		      arg))))
+
+
+(defun attribute-value* (attribute)
+  (attribute-value *object* attribute))
+
+(defmacro with-attributes (names description &body body)
+  `(let ,(loop for name in names collect 
+	      (list name `(find-attribute ,description ',name)))
+     ,@body))q
+
+
+
+
+
+
+
+
+
+		       
+	
+
+