X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/91b9f259d38073a9847ede172cdda1218f2c35fb..1cc831d4c7b9ecba47578b8a85ea046ef4e3915a:/src/attributes/standard-attributes.lisp

diff --git a/src/attributes/standard-attributes.lisp b/src/attributes/standard-attributes.lisp
index 53022aa..bdf3c80 100644
--- a/src/attributes/standard-attributes.lisp
+++ b/src/attributes/standard-attributes.lisp
@@ -1,5 +1,11 @@
 (in-package :lisp-on-lines)
 
+
+;TODO: get rid of this.
+(defun attribute.name (attribute)
+  (attribute-name attribute))
+
+
 ;;;; A few layers related to attributes
 (deflayer omit-nil-attributes)
 
@@ -8,18 +14,30 @@
  (when (attribute-value object attribute)
    (call-next-method)))
 
+;;;; Labels
 (deflayer show-attribute-labels)
 
+(defattribute attribute-label (attribute)
+  ()
+  (:default-properties
+      :attribute nil))
+
+(defdisplay
+  ((label attribute-label) object)    
+ (<:label
+  :class "lol-label"
+  (<:as-html (or (label (attribute label))
+		 (attribute-name (attribute label)) " ")
+	     "   ")))  
+
+(defvar *attribute-label-attribute*
+  (make-instance 'attribute-label))
+
 (defdisplay
     :in-layer show-attribute-labels
-    :around ((attribute standard-attribute) object)
-    
-  (<:span
-   :class "lol-label"
-   (<:as-html (or (label attribute) (attribute.name attribute)) " "))
-  (<:span
-   :class "lol-attribute"
-   (call-next-method)))
+    :around ((attribute standard-attribute) object)    
+ (display-attribute *attribute-label-attribute* object :attribute attribute)
+ (call-next-method))
 
 (deflayer use-pretty-labels)
 
@@ -31,66 +49,123 @@
      (string-capitalize
       (substitute #\Space #\- label)))))
 
-(defattribute display ()
-  ()
+(deflayer inspect-attributes)
+
+(defdisplay :in-layer inspect-attributes
+	    :around ((attribute standard-attribute) object)
+ (call-next-method)
+ (<ucw:a :action-body (ucw::call-inspector self attribute)
+	  :title
+	  (strcat "Inspect "
+			 (attribute-name attribute) ":"
+			 (description-type attribute) ":"
+			 (type-of attribute))
+	  (<:as-html "(i)")))
+
+;;;; Functional attributes
+(defattribute display-attribute ()
+  ((display-arguments
+    :accessor display-arguments
+    :initarg :display
+    :special t
+    :initform nil))
+  (:type-name display)
   (:documentation "Apply the display function to this object"))
 
-(defdisplay ((attribute display) object)
+(defdisplay ((attribute display-attribute) object)
   (apply #'display self (attribute-value object attribute)
-	 (description.properties attribute)))
+	 (display-arguments attribute)))
 
-;;;; * Base Types
+(defattribute function-attribute ()
+  ((function :accessor function-of
+	     :initarg :function
+	     :initform #'funcall
+	     :special t))
+  (:type-name function)
+  (:documentation ""))
 
-(defattribute base-attribute ()
-  ())
+(defdisplay ((function function-attribute) object)
+  (funcall (function-of function)
+	   (attribute-value object function)))
 
-(defdisplay ((base base-attribute) object)
- (<:as-html (attribute-value object base)))
 
-(defattribute base-attribute (ucw::string-field)
+;;;; Attribute Grouping
+(defattribute attribute-group ()
   ()
-  (:in-layer editor)
   (:default-properties
-      :callback nil))
+   :group nil)
+  (:type-name group))
 
-(defmethod ucw:client-value ((self base-attribute))
-  (attribute-value (object self) self))
+(defdisplay ((group attribute-group) object)
+  (apply #'display self object
+	 :attributes (attributes group)
+	 (group group)))
 
-(defmethod (setf ucw:client-value) (value (attribute base-attribute))
-  (setf (attribute-value (object attribute) attribute) value))
 
+(defattribute select-attribute (display-attribute)
+  ()
+  (:default-properties
+    :test 'meta-model::generic-equal
+    :options-getter (constantly nil))
+  (:type-name select))
 
-(defmethod render ((field base-attribute))
-  "this can only be used within a display-using-description call in the editor context, 
- it is a hack to integrate lol with ucw's new form stuff"
-  (call-next-method))
+(defdisplay ((attribute select-attribute) object)
+ (<ucw:select
+  :accessor (attribute-value object attribute)
 
-  #+ (or)
-(LET ((value (attribute-value (object field) field)))
-  (<:as-html "asd" value)
-  (<:input
-   :NAME
-   (callback field)
-   :VALUE (escape-as-html value)
-   :TYPE
-   "text"
-   :ID
-   (DOM-ID FIELD)
-   :SIZE
-   (ucw::INPUT-SIZE FIELD)))
+  :test (test attribute)
+  (dolist* (obj (funcall (options-getter attribute) object))
+    (<ucw:option
+     :value obj
+     (apply #'display* obj (display-arguments attribute))))))
 
+;;;; * Base Types
 
+(defattribute base-attribute ()
+  ()
+  (:default-properties
+      :default-value ""))
 
-(defdisplay
-    :in-layer editor  ((string base-attribute) object)
- (render string))
+(defdisplay ((base base-attribute) object)
+ (<:as-html (attribute-value object base)))
 
+(defattribute base-attribute ()
+  ()
+  (:in-layer editor)
+  (:default-properties 
+    :callback nil
+    :default-value nil
+    :default-value-predicate #'null
+    :dom-id (js:gen-js-name-string :prefix "_ucw_")
+    :input-size nil))
+
+(define-layered-function display-value (attribute value)
+  (:method (attribute value)
+    (if (funcall (default-value-predicate attribute) value)
+	(default-value attribute)
+	value)))
+
+(defdisplay
+  :in-layer editor ((field base-attribute) object)
+  (LET ((value (attribute-value (object field) field)))
+    (<:input
+     :NAME
+     (callback field)
+     :VALUE (escape-as-html (strcat (display-value field value)))
+     :TYPE
+     "text"
+     :ID
+     (DOM-ID FIELD)
+     :SIZE
+     (INPUT-SIZE FIELD))))
 
 (defdisplay
     :in-layer editor :around ((string base-attribute) object)
-    (dletf (((callback string) (ucw::make-new-callback
-				#'(lambda (val)
-				    (setf (attribute-value object string) val))))
+    (dletf (((callback string)
+	     (or (callback string)
+		 (ucw::register-callback
+		  #'(lambda (val)
+		      (setf (attribute-value object string) val)))))
 	    ((object string) object))
       (call-next-method)))
 
@@ -102,7 +177,11 @@
   (:default-properties
       :escape-html-p t
     :size nil
-    :max-length nil))
+    :max-length nil
+    :default-value ""))
+
+
+#| 
 
 (defdisplay :in-layer omit-nil-attributes
 	    :around ((attribute string-attribute) object)
@@ -118,7 +197,7 @@
 
 
 ;;;; editor
-(defattribute string-attribute (base-attribute)
+#+nil (defattribute string-attribute (base-attribute)
   ()
   (:in-layer editor)
   (:default-properties
@@ -159,7 +238,7 @@
 
 (defdisplay :in-layer editor ((string text-attribute) object)
  (<:textarea
-  :id (id string)
+  :id (dom-id string)
   :name (callback string)
   (or (attribute-value object string) "")))
 
@@ -205,7 +284,7 @@
 
     (<:div
      :class "lol-image-thumbnails"
-     (<:as-html "imagie")))
+     (<:as-html "imagie"))) |#