From 2b0fd9c886908c6492c66cc30fcacf5fd600bf8e Mon Sep 17 00:00:00 2001
From: Drew Crampsie <drewc@tech.coop>
Date: Thu, 23 Feb 2006 04:49:10 -0800
Subject: [PATCH] Major patch touching a lot, representing the new lol. is
 mostly drop-in backwards compatable.

darcs-hash:20060223124910-5417e-ebb4390759c4cfba78cbb388636d2cea65059049.gz
---
 lisp-on-lines.asd              |  11 +-
 src/attributes/numbers.lisp    |  26 +++
 src/backwards-compat.lisp      |  31 ++++
 src/components/ajax.lisp       |   6 +-
 src/components/dojo.lisp       |   3 +-
 src/components/search.lisp     | 139 +++++++++++++++
 src/defdisplay.lisp            | 226 +++++++++++++++---------
 src/dojo-attributes.lisp       |  85 +++++++++
 src/mewa.lisp                  | 283 ++++++++++++++++++------------
 src/packages.lisp              |   4 +
 src/properties.lisp            |  57 ++++++
 src/relational-attributes.lisp |  53 ++++--
 src/slot-presentations.lisp    |   3 +-
 src/special-initargs.lisp      |  38 ++++
 src/standard-attributes.lisp   | 221 +++++++++++++++++------
 src/standard-display.lisp      | 310 ++++++++++++++++-----------------
 src/standard-occurence.lisp    |  24 +++
 src/standard-wrappers.lisp     |  82 ++++++---
 src/ucw-test-component.lisp    |  10 +-
 19 files changed, 1155 insertions(+), 457 deletions(-)
 create mode 100644 src/attributes/numbers.lisp
 create mode 100644 src/components/search.lisp
 rewrite src/defdisplay.lisp (93%)
 create mode 100644 src/dojo-attributes.lisp
 create mode 100644 src/properties.lisp
 create mode 100644 src/special-initargs.lisp
 rewrite src/standard-attributes.lisp (68%)
 rewrite src/standard-display.lisp (85%)
 create mode 100644 src/standard-occurence.lisp
 rewrite src/standard-wrappers.lisp (76%)

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index cee71e9..9629103 100644
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -12,7 +12,11 @@
     :components ((:static-file "lisp-on-lines.asd")
 		 (:file "src/packages")
 		 (:module :src
-			  :components ((:file "static-presentations")
+			  :components ((:file "special-initargs")
+				       (:file "properties")
+				       ;;;; legacy UCW presentations
+				       (:file "static-presentations")
+				       
 				       (:file "mewa")
 				       (:file "validation")
 				       (:file "validation/email-address")
@@ -22,12 +26,17 @@
 				       (:file "slot-presentations/date")
 				       (:file "defdisplay")
 				       (:file "standard-display")
+				       (:file "standard-occurence")
 				       (:file "standard-attributes")
+				       (:file "dojo-attributes")
 				       (:file "standard-wrappers")
 				       (:file "relational-attributes")
 
 				       (:file "backwards-compat"))
 			  :serial t)
+		 (:module :attributes
+			  :pathname "src/attributes/"
+			  :components ((:file "numbers")))
 		 (:module :components
 			  :pathname "src/components/"
 			  :components ((:file "range-list")
diff --git a/src/attributes/numbers.lisp b/src/attributes/numbers.lisp
new file mode 100644
index 0000000..8eeff63
--- /dev/null
+++ b/src/attributes/numbers.lisp
@@ -0,0 +1,26 @@
+(in-package :lisp-on-lines)
+
+(defattribute number-attribute (base-attribute)
+  ()
+  (:type-name number))
+
+;;;; INTEGER
+(defattribute integer-attribute (base-attribute)
+  ()
+  (:type-name integer))
+
+;;;; REALS
+
+(defattribute real-attribute (base-attribute)
+  ()
+  (:type-name real))
+
+
+;;;; Currency
+(defattribute currency-attribute (base-attribute)
+  ()
+  (:type-name currency))
+
+(defdisplay
+   ((currency currency-attribute) object)
+ (<:as-html (format nil "$~$" (attribute-value object currency))))
diff --git a/src/backwards-compat.lisp b/src/backwards-compat.lisp
index c2ab9e8..429d325 100644
--- a/src/backwards-compat.lisp
+++ b/src/backwards-compat.lisp
@@ -7,7 +7,38 @@
 ;;;; with the past. You learn to live with it.
 
 
+(defmethod find-old-type (type)
+  type)
+
 ;;!legacy string
 (defmethod find-attribute-class-for-type ((type (eql 'mewa-string)))
   'string-attribute)
+;; legacy int
+(defmethod find-attribute-class-for-type ((type (eql 'mewa-integer)))
+  'integer-attribute)
+
+;; currency
+(defmethod find-attribute-class-for-type ((type (eql 'mewa-currency)))
+  'currency-attribute)
+;; legacy relations
+
+(defmethod find-attribute-class-for-type ((type (eql 'ajax-foreign-key)))
+  'lol::has-a)
+
+
+(defmethod find-attribute-class-for-type ((type (eql 'foreign-key)))
+  'lol::has-a)
+
+(defmethod find-layer-for-type ((type (eql 'mewa-one-line-presentation)))
+  'one-line)
+
+(defmethod find-old-type ((type (eql 'one-line)))
+  'mewa-one-line-presentation)
+
+(defmethod find-old-type ((type (eql 'one-line)))
+  'mewa-one-line-presentation)
+
+
+
+
 
diff --git a/src/components/ajax.lisp b/src/components/ajax.lisp
index 6b4f23f..f3a9f83 100644
--- a/src/components/ajax.lisp
+++ b/src/components/ajax.lisp
@@ -199,6 +199,7 @@ but here's what i use."
 		     (meta-model:explode-foreign-key instance (slot-name slot)))))))
     
     (flet ((render-s () (when foreign-instance (call-next-method))))
+
       (if (slot-boundp slot 'ucw::place)
 	  (cond 
 	    ((editablep slot)
@@ -212,11 +213,12 @@ but here's what i use."
 	     (<ucw:render-component :component (live-search slot))
 	     #+ (or) (<ucw:submit :action (revert-foreign-slot slot)
 			  :value "Undo")
-			      (<ucw:submit :action  (mewa::search-records slot instance) :value "find" :style "display:inline"))
+			      #+ (or) (<ucw:submit :action  (mewa::search-records slot instance) :value "find" :style "display:inline"))
 	    ((mewa::linkedp slot)
 	     (<ucw:a :action (mewa::view-instance slot foreign-instance) 
 		     (render-s)))
 	    (t       
 	     (render-s)))
 	  ;; presentation is used only for rendering
-	  (render-s)))))
\ No newline at end of file
+	  (render-s))))
+)
\ No newline at end of file
diff --git a/src/components/dojo.lisp b/src/components/dojo.lisp
index c1d36a9..1bfbac8 100644
--- a/src/components/dojo.lisp
+++ b/src/components/dojo.lisp
@@ -72,8 +72,7 @@
 		      ,(lol::make-action-url
 			,component
 			(progn
-			  ,@actions
-			  (call-component nil (output-component self))))))
+			  ,@actions))))
 		 ,@ (unless
 			,(getf args :post-content)
 		      `(:post-content (+ ,,@(loop for c in callbacks
diff --git a/src/components/search.lisp b/src/components/search.lisp
new file mode 100644
index 0000000..4b4e5e5
--- /dev/null
+++ b/src/components/search.lisp
@@ -0,0 +1,139 @@
+(in-package :lisp-on-lines)
+
+
+(defmethod simple-word-search (class-name slots search-terms)  
+  (select class-name 
+	  :where  (simple-word-search-where class-name slots search-terms)
+	  :flatp t))
+
+(defmethod simple-word-search-where (class-name slots search-terms)
+    (sql-or 
+		  (mapcar #'(lambda (term)
+			      (apply #'sql-or 
+				     (mapcar #'(lambda (slot)  
+						 (sql-uplike
+						  (sql-slot-value class-name slot)
+						  (format nil "%~a%" term)))
+					     slots)))
+			  search-terms)))
+
+(defmethod find-slots-of-type (model &key (type 'string)
+			      (types '((string)) types-supplied-p))
+  "returns a list of slots matching TYPE, or matching any of TYPES"
+  (let (ty)
+    (if types-supplied-p 
+	(setf ty types)
+	(setf ty (list type)))
+    (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
+					 (first st)))
+	     (list-slot-types model)))))
+
+;;;; * Simple Search Component
+
+(defcomponent simple-search ()
+  ((search-term :initarg :search-term :accessor search-term :initform "")
+   (listing :initarg :listing :accessor listing :initform :listing)
+   (select-returns-p :initarg :select-returns-p :accessor select-returns-p :initform nil)
+   (search-tables :initarg :search-tables :accessor search-tables :initform nil)))
+
+(defmethod render-on ((res response)(self simple-search))
+  (<ucw:input :type "text" :accessor (search-term self))
+  (<ucw:submit :action (do-search self)))
+
+(defmethod perform-simple-search ((self simple-search) &key (base-classes (meta-model:list-base-classes :clsql)))
+  (when (search-tables self)
+    (setf base-classes (search-tables self)))
+  (remove nil (mapcar #'(lambda (x) 
+			  (simple-word-search  x 
+					       (find-slots-of-type x) 
+					       (split-sequence #\Space (search-term self))))
+		      base-classes)))
+
+
+(defaction do-search ((self simple-search))
+  (let* ((target (or (slot-value self 'ucw::parent) self))
+	 (result (call-component 
+		  target 
+		  (make-instance 'simple-search-results 
+				 :listing (listing self)
+				 :results 
+				 (perform-simple-search self :base-classes 
+							(remove 'claim-history (meta-model:list-base-classes :clsql)))
+				 :search-term (split-sequence #\Space (search-term self))))))
+    (when result
+      (if (select-returns-p self)
+	  (answer result)
+	  (call-component target (make-presentation result :type :viewer))))))
+
+(defcomponent simple-search-results ()
+  ((results :accessor results :initarg :results :initform nil)
+   (listing :initarg :listing :accessor listing :initform :listing)
+   (search-term :initarg :search-term :accessor search-term :initform nil)))
+
+(defmethod view-name (view)
+  (class-name (class-of view)))
+
+(defmethod render-on ((res response) (self simple-search-results))
+  (<:h3 (<:as-html "Search results for " (search-term self)))
+  (dolist (r (results self))
+    (<:fieldset 
+     (<:legend (<:as-html (format nil "Found ~A results in ~A:" (length r) (view-name (car r)))))
+    (render-on res 
+	       (embed-component 
+		self 
+		(make-presentation 
+		 (car r) 
+		 :type :listing 
+		 :initargs `(:instances ,r)))))))
+
+(defaction ok ((self simple-search-results) &optional arg)
+  (declare (ignore arg))
+  (answer nil))
+
+
+
+;;;; * Advanced Search Component 
+
+(defcomponent advanced-search () 
+  ((simple-search :component simple-search :accessor simple-search)
+   (search-table :accessor search-table :initform nil)
+   (search-presentation :accessor search-presentation :initform nil)))
+
+(defmethod render-on ((res response) (self advanced-search))
+  (<:h2 (<:as-html "Advanced Search"))
+  ;; simple search :
+  (<:fieldset 
+   (<:legend (<:as-html "simple text search")) 
+   (render-on res (simple-search self)))
+  ;; complex-search
+  (<:fieldset 
+   (<:legend (<:as-html "Complex Search"))
+   (<:as-html "Choose search table:")
+   (<ucw:select 
+    :accessor (search-table self)
+    (dolist (tbl (meta-model:list-base-classes :clsql))
+      (<ucw:option :value tbl (<:as-html tbl))))
+   (<ucw:submit :action (select-search-table self) :value "select")
+   ;;
+   (when (search-presentation self)
+     (<:fieldset 
+      (<:legend (<:as-html (format nil "search ~A" (search-table self))))
+      (render-on res (embed-component self (search-presentation self)))))))
+
+
+(defun make-search-presentation (instance )
+  (make-instance 'mewa::mewa-presentation-search
+		     :search-presentation (make-presentation instance :type :search-model)
+		     :list-presentation (make-presentation instance :type :listing
+(defaction select-search-table ((self advanced-search))
+  (let* ((i (make-instance (search-table self)))
+	 (p (make-search-presentation i)))
+    (embed-component self p)
+    (setf (search-presentation self) p) ))
+
+
+(defcomponent table-search 
+
+
+
+
diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
dissimilarity index 93%
index 4363a0f..89f6987 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -1,81 +1,145 @@
-(in-package :lisp-on-lines)
-
-(defmethod find-properties (object)
-  (list))
-
-(defmethod find-properties ((attribute standard-attribute))
-  (warn "atttributre properties ~A" (attribute.properties attribute))
-  (attribute.properties attribute))
-
-(defmacro with-properties ((properties &optional prefix)  &body body)
-  (with-unique-names (p)
-    (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
-	  (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
-	  (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
-      `(let ((,p ,properties))
-	(flet ((,get  (p)
-		 (getf ,p p))
-	       (,set (p v)
-		 (setf (getf ,p p) v))
-	       (,props ()
-		 ,p))
-	  (declare (ignorable #',get #',set #',props))
-	  ,@body)))))
-
-
-;;;;; Macros
-(defmacro do-attributes ((var occurence attributes) &body body)
-  (with-unique-names (att properties type)
-    `(loop for ,att in ,attributes
-      do (let* ((,att (ensure-list ,att))
-                (,properties (rest ,att))
-                (,type (getf ,properties :type))
-                (,var (if ,type
-                          (make-attribute :name (first ,att) :type ,type :properties ,properties)
-                          (find-attribute ,occurence (first ,att)))))
-           (with-properties ((plist-union (rest ,att) (find-properties ,var)) ,var)
-             ,@body)))))
-
-
-
-
-(defmacro defdisplay (object (&key in-layer combination
-				   (description t
-						description-supplied-p)
-				   (component 'component
-					      component-supplied-p))
-		      &body body)
-  (with-unique-names (d c p)
-    (let ((obj (car (ensure-list object))))
-      `(define-layered-method display-using-description
-	,@(when in-layer `(:in-layer ,in-layer))
-	,@(when combination`(,combination))
-	(,(cond
-	   (description-supplied-p
-	    (setf d description))
-	   ((null description)
-	    d)
-	   (t
-	    `(,d standard-occurence)))
-	 ,(cond
-	   (component-supplied-p
-	    (setf c component))
-	   ((null component)
-	    c)
-	   (t
-	    `(,c component)))
-	 ,object ,p)
-	(with-component (,c) 
-	  (with-properties ((plist-union ,p (find-properties ,(car (ensure-list d) ))))
-	    ,(if (not description-supplied-p)
-		 `(progn
-		   
-		   (setp :attributes (or (getp :attributes) (list-slots ,obj)))		   
-		   (macrolet ((do-attributes* ((var &optional attributes) &body body)
-				`(do-attributes (,var ,',d (or ,attributes (getp :attributes)))
-				  
-				  (flet ((display-current-attribute ()
-					   (display-using-description* ,var ,',obj (,(intern (strcat var "-PROPERTIES"))))))
-				  ,@body))))
-		     ,@body))
-		 `(progn ,@body))))))))
\ No newline at end of file
+(in-package :lisp-on-lines)
+
+(define-layered-function display-using-description (description object component)
+  (:documentation
+   "Render the object in component, 
+    using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
+
+(define-layered-method
+    display-using-description (d o c)
+    (<:as-html "default :" o))
+
+(defmethod find-layer-for-type (type)
+  type)
+
+
+(define-layered-function display (component object &rest args)
+  (:documentation
+   "Displays OBJECT in COMPONENT."))
+
+(define-layered-method display ((component t) (object t)
+				&rest properties
+				&key type
+				&allow-other-keys)
+    "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
+
+    (let* ((occurence (find-occurence object))
+	   (description (or (find-display-attribute
+			     occurence
+			     (setf type (or type (description.type occurence))))
+			   occurence)))
+      (if description
+	  (dletf (((description.type occurence) type)
+		  ((description.layers description) (append `(+
+
+							      ;;find-layer-for-type is a
+							      ;; backwards compat thing
+							   ,(find-layer-for-type
+							     type))
+							 (description.layers description)))
+		  ((attributes description) (or
+					     (attributes description)
+					     (list-slots object))))
+	    (funcall-with-description
+	     description properties
+	     #'display-using-description description object component))
+	  (error "no description for ~A" object))))
+
+;;;;; Macros
+;;;; TODO: " should really be a funcall-with function with a small wrapper."
+
+(defun funcall-with-description (description properties function &rest args)
+  (if description
+      (dletf* (((description.type description) (or
+						(getf properties :type)
+						(description.type description)))
+	    
+	       ((description.layers description) (append 
+							 (description.layers description)
+							 (getf properties :layers)))
+	       ((description.properties description) properties))
+	(funcall-with-layers 
+	 (description.layers description)
+	 #'(lambda ()
+	     (funcall-with-special-initargs
+	      description properties
+	      #'(lambda ()
+		  (apply function args))))))
+      (apply function args)))
+
+
+
+(defmacro with-description ((description &rest properties) &body body)
+  `(funcall-with-description ,description (if ',(cdr properties)
+					       (list ,@properties)
+					       ,(car properties))
+    #'(lambda ()
+	,@body)))
+
+(defmacro do-attributes ((var description &optional (attributes `(attributes ,description))) &body body)
+  (with-unique-names (att properties type)
+    `(dolist* (,att  ,attributes)
+      (let* ((,att (ensure-list ,att))
+                (,properties (rest ,att))
+                (,type (getf ,properties :type))
+                (,var (let ((a (find-attribute ,description (first ,att))))
+			(if ,type
+			    (apply #'make-attribute :name (first ,att) :type ,type ,properties)
+			    (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
+	(funcall-with-description ,var ,properties
+	  #'(lambda () ,@body))))))
+
+(defmacro with-component ((component) &body body)
+  `(let ((self ,component))
+    (declare (ignorable self))
+    (flet ((display* (thing &rest args)
+	     (apply #'display ,component thing args))
+	   (display-attribute (attribute obj &optional props)
+	     (if props
+		 (funcall-with-description
+		  attribute props
+		  #'display-using-description attribute obj ,component)
+		 (display-using-description attribute obj ,component))))
+      (declare (ignorable #'display* #'display-attribute))
+      ,@body)))
+
+(defmacro defdisplay (&body body)
+  (loop with in-layerp = (eq (car body) :in-layer)
+	with layer = (if in-layerp (cadr body) 't)
+	for tail on (if in-layerp (cddr body) body)
+	until (listp (car tail))
+	collect (car tail) into qualifiers
+	finally
+	(when (member :in-layer qualifiers)
+	  (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
+	(return
+	  (destructuring-bind (description object &optional component) (car tail) 
+	    (with-unique-names (d c)
+	      (let (standard-description-p)
+		`(define-layered-method
+		  display-using-description
+		  :in-layer ,layer
+		  ,@qualifiers
+		
+		  (,(cond
+		     ((listp description)
+		      (setf d (car description))
+		      description)
+		     (t
+		      (setf d description)
+		      (setf standard-description-p t)
+		      `(,d description)))
+		   ,object
+		   ,(cond
+		     ((null component)
+		      `(,c component))
+		     ((listp component)
+		      (setf c (car component))
+		      component)
+		     (t
+		      (setf c component)
+		      `(,c component))))
+		  (with-component (,c)  
+			 ,@(cdr tail)))))))))
+
+
diff --git a/src/dojo-attributes.lisp b/src/dojo-attributes.lisp
new file mode 100644
index 0000000..862ee11
--- /dev/null
+++ b/src/dojo-attributes.lisp
@@ -0,0 +1,85 @@
+(in-package :lisp-on-lines)
+
+(deflayer dojo)
+
+(define-layered-class
+    attribute :in-layer dojo ()
+  ((dojo-type :accessor dojo-type :initarg :dojo-type :initform nil :special t)))
+
+
+(defgeneric display-as-dojo-type (type attribute object component))
+
+(defdisplay
+  :in-layer dojo :after ((attribute standard-attribute) object)
+ (when (dojo-type attribute)
+   (display-as-dojo-type (dojo-type attribute) attribute object self)))
+
+(defcomponent dojo-test (window-component)
+  (
+   (results :accessor results :initarg :results)))
+
+(defmethod render ((self dojo-test))
+  (<:as-is (js:js* `(array
+		     ,@(loop for r in (results self)
+			     for n upfrom 0
+			     collect `(array , 
+				       (with-output-to-string (s)
+					 (yaclml:with-yaclml-stream s
+					   (display self r :type 'as-string))) ,n))))))
+
+
+(defmethod display-as-dojo-type ((type (eql 'combo-box)) attribute object component)
+  
+  (let* ((search-function (search-function attribute))
+	(select-function (select-function attribute))
+	(select-callback (ucw::make-new-callback (lambda (x)
+						   (warn "setting index to ~A" 							    (parse-integer x))
+						   (funcall select-function 
+							    (parse-integer x))))))
+    "The combo box widget"
+  (<ucw:script
+   `(dojo.require "dojo.*")
+   `(dojo.require "dojo.widget.*")
+   `(dojo.require "dojo.widget.html.ComboBox")
+   (js:with-unique-js-names (element combo-box)
+
+     `(dojo.add-on-load
+       (lambda ()
+	 (setf ,element (dojo.by-id ,(id attribute)))
+	 (setf ,combo-box
+	       (dojo.widget.from-script
+		"ComboBox"
+		(create
+		 :data-url (+ , (lol::make-action-url
+				 component
+				 (call-component
+				  (context.window-component *context*)
+				  (make-instance 'dojo-test
+						 :results
+						 (funcall search-function
+							  (attribute-value object attribute)))))
+				"&"
+				,(escape-as-uri (callback attribute))
+				"=%{searchString}")
+		 :mode "remote")
+		,element))
+	 ((slot-value ,combo-box 'set-value) (slot-value ,element 'value))
+	 (dojo.event.connect
+	  ,combo-box "selectOption"
+	  (lambda ()
+	    (setf (slot-value ,element 'value)
+		  (slot-value ,combo-box 'selected-result))
+	    (dojo.io.bind
+	     (create
+	      :url (+ ,(lol::make-action-url
+			component
+			nil)
+		      "&"
+		      ,(escape-as-uri (callback attribute))
+		      "="
+		      (slot-value ,combo-box 'selected-result)
+		      "&"
+		      ,select-callback
+		      "="
+		      (slot-value ,combo-box 'combo-box-selection-value.value))))))))))))
+  
\ No newline at end of file
diff --git a/src/mewa.lisp b/src/mewa.lisp
index c8fe7a5..7bb9522 100644
--- a/src/mewa.lisp
+++ b/src/mewa.lisp
@@ -4,41 +4,41 @@
 
 (defparameter *default-type* :ucw)
 
-;;;; I think these are unused now
-(defmethod perform-set-attributes ((occurence-name t) definitions)
-  (dolist (def definitions)
-    (funcall #'set-attribute occurence-name (first def) (rest def))))
-
-(defmethod perform-set-attribute-properties ((occurence-name t) definitions)
-  (dolist (def definitions)
-    (funcall #'set-attribute-properties occurence-name (car def) (cdr def))))
-
-;;;; PLIST Utilities.
-
-(defun plist-nunion (new-props plist)
-  "Destructive Merge of plists. PLIST is modified and returned. 
-NEW-PROPS is merged into PLIST such that any properties
-in both PLIST and NEW-PROPS get the value in NEW-PROPS. 
-The other properties in PLIST are left untouched."
-  (loop for cons on new-props by #'cddr
-	do (setf (getf plist (first cons)) (second cons))
-	finally (return plist))
-  plist)
-
-(defun plist-union (new-props plist)
-  "Non-destructive version of plist-nunion"
-		   (plist-nunion new-props (copy-list plist)))
+(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)
+   (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
 
 (defvar *occurence-map* (make-hash-table)
-  "Presentations are created by associating an 'occurence' 
+  "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 ()
+    standard-occurence (description)
     ((attribute-map :accessor attribute-map :initform (make-hash-table)))
     (:documentation
      "an occurence holds the attributes like a class holds slot-definitions.
@@ -66,36 +66,59 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
     (find-or-create-occurence (class-name (class-of instance)))))
 
 
+(define-layered-class
+    attribute (description)
+    ((name :layered-accessor attribute.name
+	   :initarg :name
+	   :initform (gensym "ATTRIBUTE-")
+	   :special t)
+     (occurence :accessor occurence :initarg :occurence :initform nil)
+     (label :initarg :label :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))))
 
 (define-layered-class
-    standard-attribute ()
-    ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
-     (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
-     (properties :layered-accessor attribute.properties :initarg :properties :initform nil))
+    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)))
     (: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."))
 
 (defmacro defattribute (name supers slots &rest args)
   (let ((type (or (second (assoc :type-name args)) name))
-	(properties (cdr (assoc :default-properties args))))
+	(layer (or (second (assoc :in-layer args)) nil))
+	(properties (cdr (assoc :default-properties args)))
+	(cargs  (remove-if #'(lambda (key)
+		   (or (eql key :type-name)
+		       (eql key :default-properties)
+		       (eql key :default-initargs)
+		       (eql key :in-layer)))
+			 args
+	       :key #'car)))
+    
     `(progn
-      
       (define-layered-class
 	  ;;;; TODO: fix the naive way of making sure s-a is a superclass
-	  ,name ,(or supers '(standard-attribute))
-	  ,slots
-	  #+ (or) ,@ (cdr args)
-	  (:default-initargs :properties (list ,@properties)))
+	  ;;;; Need some MOPey goodness.
+	  ,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute))
+	  ,(append slots (properties-as-slots properties)) 
+	  #+ (or) ,@ (cdr cargs)
+	  ,@cargs
+	  (:default-initargs :properties (list ,@properties)
+	    ,@ (cdr (assoc :default-initargs args))))
+
       (defmethod find-attribute-class-for-type ((type (eql ',type)))
 	',name))))
 
-(defmethod print-object ((self standard-attribute) stream)
-  (print-unreadable-object (self stream :type t)
-    (with-slots (name type) self
-      (format stream "~A ~A" name type))))
+
 
 (define-layered-class
-    presentation-attribute (standard-attribute)
+    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."))
@@ -110,21 +133,21 @@ using the attributes defined in an occurence. Presentation Attributes are always
 (defmethod find-attribute-class-for-name (name)
   "presentation attributes are named using keywords"
   (if (keywordp name)
-      'presentation-attribute
+      'display-attribute
       'standard-attribute))
 
-(defun make-attribute (&key name type properties)
-  (let ((i (make-instance (or (find-attribute-class-for-type type)
-		     (find-attribute-class-for-name name)) 
-		 :name name :type type)))
-    (setf (attribute.properties i)
-	  (plist-union properties (attribute.properties i)))
-    i)) 
+(defun make-attribute (&rest args &key name type &allow-other-keys)
+  (apply #'make-instance
+	 (or (find-attribute-class-for-type type)
+	     (find-attribute-class-for-name name))
+	 args)) 
 
-(defmethod ensure-attribute ((occurence standard-occurence) name type properties)
+(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
   "Creates an attribute in the given occurence"
-  (setf (gethash name (attribute-map occurence))
-	(make-attribute :name name :type type :properties properties)))
+  (let ((attribute (apply #'make-attribute :occurence occurence args)))
+    (setf (description.properties attribute) args)
+    (setf (gethash name (attribute-map occurence))
+	  attribute)))
 
 (defmethod find-attribute ((occurence standard-occurence) name)
   (gethash name (attribute-map occurence)))
@@ -133,12 +156,11 @@ using the attributes defined in an occurence. Presentation Attributes are always
   (loop for att being the hash-values of (attribute-map occurence)
 	collect att))
 
-(defmethod ensure-attribute (occurence-name name type properties)
-  (ensure-attribute
+(defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
+  (declare (ignore name type))
+  (apply #'ensure-attribute
    (find-occurence occurence-name)
-   name
-   type
-   properties)) 
+   args)) 
 
 ;;;; The following functions make up the public interface to the
 ;;;; MEWA Attribute Occurence system.
@@ -147,48 +169,76 @@ using the attributes defined in an occurence. Presentation Attributes are always
   (find-all-attributes (find-occurence occurence-name)))
 
 (defmethod find-attribute (occurence-name attribute-name)
-  "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
+  "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
   (find-attribute (find-occurence occurence-name) attribute-name))
 
-(defmethod (setf find-attribute) ((def list) occurence-name attribute-name)
-  (ensure-attribute occurence-name attribute-name (first def) (rest def)))
+(defmethod (setf find-attribute) ((attribute-spec list) occurence-name attribute-name)
+  "Create a new attribute in the occurence.
+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 set-attribute (occurence-name attribute-name definition &key (inherit t))
-  (let ((att (find-attribute occurence-name attribute-name)))
-      (setf (find-attribute occurence-name attribute-name) 
-	(if (and att inherit) 
-	    (cons (car definition) 
-		  (plist-union (cdr definition)
-			 (attribute.properties att)))
-	    definition)))) 
+
+(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)
-  (let ((a (find-attribute occurence-name attribute)))
-    (if a
-	(setf (attribute.properties a) (plist-nunion properties (attribute.properties a)))
-	(error "Attribute ~A does not exist" attribute))))
+  (setf (description.properties attribute) (plist-nunion
+					    properties
+					    (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)))
+		   
+		   (if s-n
+		       (progn
+			 (setf (slot-value attribute
+					   (cdr s-n))
+			       value))
+		       (warn "Cannot find initarg ~A in attribute ~S" initarg attribute)))
+	      finally (return attribute)))
+
+(defmethod set-attribute (occurence-name attribute-name attribute-spec &key (inherit t))
+  "If inherit is T, sets the properties of the attribute only, unless the type has changed.
+otherwise, (setf find-attribute)"
+  (let ((att (find-attribute occurence-name attribute-name)))
+    (if (and att inherit (or (eql (car attribute-spec)
+			      (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))))))))
 
 (defmethod perform-define-attributes ((occurence-name t) attributes)
   (loop for attribute in attributes
 	do (destructuring-bind (name type &rest args)
 		  attribute
-		(cond ((eq type t)
-		       ;;use the existing (default) type
-		       (set-attribute-properties occurence-name name args))
-		      ((not (null type))
-		       ;;set the type as well
-		       (set-attribute occurence-name name (cons type args)))))))
+	     (cond ((not (null type))
+		    ;;set the type as well
+		    (set-attribute occurence-name name (cons type args)))))))
 		       
 (defmacro define-attributes (occurence-names &body attribute-definitions)
   `(progn
     ,@(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)))
 
 (defmethod setter (attribute)
   (warn "Setting ~A in ~A" attribute *context*)
-  (let ((setter (getf (attribute.properties attribute) :setter))
-	(slot-name (getf (attribute.properties attribute) :slot-name)))
+  (let ((setter (getf (description.properties attribute) :setter))
+	(slot-name (getf (description.properties attribute) :slot-name)))
     (cond (setter
 	   setter)
 	  (slot-name
@@ -196,29 +246,38 @@ using the attributes defined in an occurence. Presentation Attributes are always
 	       (setf (slot-value object slot-name) value)))
 	  (t
 	   #'(lambda (value object)
-	     (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
+	       (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
     
-(defmethod getter (attribute)
-  (let ((getter (getf (attribute.properties attribute) :getter))
-	(slot-name (getf (attribute.properties attribute) :slot-name)))
-    (cond (getter
-	   getter)
-	  (slot-name
-	   #'(lambda (object)
-	       (when (slot-boundp object slot-name)
-		 (slot-value object slot-name)))))))
-
 
 (define-layered-function attribute-value (instance attribute)
   (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
 
 (define-layered-method attribute-value (instance (attribute standard-attribute))
-  (funcall (getter attribute) instance))
+    (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)))))))
 
 (define-layered-function (setf attribute-value)  (value instance attribute))
 
-(define-layered-method (setf attribute-value) (value instance (attribute standard-attribute))
-  (funcall (setter attribute) value instance))
+(define-layered-method
+    (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))
+	  (t
+	   (error "Cannot set ~A in ~A" attribute instance)))))
 
 
 ;;;; ** Default Attributes
@@ -251,13 +310,13 @@ using the attributes defined in an occurence. Presentation Attributes are always
 
 (defun find-presentation-attributes (occurence-name)
   (loop for att in (find-all-attributes occurence-name)
-	when (typep att 'presentation-attribute)
+	when (typep att 'display-attribute)
 	 collect att))
 
 (defun attribute-to-definition (attribute)
   (nconc (list (attribute.name attribute)
-	       (attribute.type attribute))
-	 (attribute.properties attribute)))
+	       (description.type attribute))
+	 (description.properties attribute)))
 
 (defun find-default-presentation-attribute-definitions ()
   (if (eql *default-attributes-class-name* 'default)
@@ -273,9 +332,9 @@ using the attributes defined in an occurence. Presentation Attributes are always
 	 (real-default (find-attribute 'default type)))
     (cond
       (possible-default
-	(attribute.type possible-default))
+	(description.type possible-default))
        (real-default
-	(attribute.type real-default))
+	(description.type real-default))
        (t type))))
 
 (defun gen-presentation-slots (instance)
@@ -292,7 +351,10 @@ using the attributes defined in an occurence. Presentation Attributes are always
 
 
 	  
-;;;presentations 
+;;;; DEPRECIATED: Mewa presentations
+;;;; this is legacy cruft. 
+
+
 (defcomponent mewa ()
   ((instance :accessor instance :initarg :instance) 
    (attributes
@@ -344,21 +406,22 @@ using the attributes defined in an occurence. Presentation Attributes are always
   (declare (type list plist) (type symbol att-name))
   "This is a ucw specific function that will eventually be factored elsewhere."
   (let* ((attribute (find-attribute occurence att-name))
-	 (type (when attribute (or type (attribute.type attribute))))
+	 (type (when attribute (or type (description.type attribute))))
 	 (class-name 
 	  (or (gethash (if (consp type)
 			   (car type)
 			   type)
 		       *presentation-slot-type-mapping*) 
 	      (error  "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation))))
-   
-    (cons (attribute.name attribute) (apply #'make-instance 
+
+    ;(warn "~%~% **** Making attribute ~A ~%~%" class-name)
+   (cons (attribute.name attribute) (apply #'make-instance 
 				   class-name
 				   (append (plist-nunion
 					    plist
 					    (plist-union
 					     (global-properties parent-presentation)
-					     (attribute.properties attribute)))
+					     (description.properties attribute)))
 					   (list :size 30 :parent parent-presentation))))))
 
 (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)
@@ -432,15 +495,17 @@ in that object presentation."
 
 
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
+  (warn "making old-style for ~A ~A ~A" object type initargs)
   ;(warn "Initargs : ~A" initargs)
-  (let* ((a (find-attribute object type))   
+  (let* ((a (find-attribute object type))
+	 (d-a (when a (find-display-attribute (occurence a) (description.type (occurence  a)))))
 	 (i (apply #'make-instance
-		   (if a
-		       (attribute.type a)
+		   (if d-a 
+		       (find-old-type (description.type a))
 		       type) 
 		   (plist-union initargs (when a
-					   (attribute.properties a))))))
-    
+					   (description.properties a))))))
+    (warn "attribute? ~A ~A " (and a (description.type  (find-attribute object type)) ) 					   (description.properties a))
     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     (setf (slot-value i 'initializedp) t)
diff --git a/src/packages.lisp b/src/packages.lisp
index 483f5ea..66cb2ed 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -52,6 +52,7 @@
    :display-using-description
    :call-display
 
+
    ;;;;a wrapper for calling make-presentation
    :call-view
    :present-view
@@ -67,8 +68,11 @@
    :make-presentation
    :call-presentation
 
+   :find-occurence
+
    ;;attributes
    :attributes
+   :attribute-value
    :define-attributes
    :with-default-attributes
    :set-default-attributes
diff --git a/src/properties.lisp b/src/properties.lisp
new file mode 100644
index 0000000..9c2c129
--- /dev/null
+++ b/src/properties.lisp
@@ -0,0 +1,57 @@
+(in-package :lisp-on-lines)
+
+
+
+
+;;;; PLIST Utilities.
+
+(defun plist-nunion (new-props plist)
+  "Destructive Merge of plists. PLIST is modified and returned. 
+NEW-PROPS is merged into PLIST such that any properties
+in both PLIST and NEW-PROPS get the value in NEW-PROPS. 
+The other properties in PLIST are left untouched."
+  (loop for cons on new-props by #'cddr
+	do (setf (getf plist (first cons)) (second cons))
+	finally (return plist))
+  plist)
+
+(defun plist-union (new-props plist)
+  "Non-destructive version of plist-nunion"
+		   (plist-nunion new-props (copy-list plist)))
+
+
+
+
+    
+
+(defun slots-as-properties (object)
+  "Makes a plist by making a keyword from the ...ahh .. read the damn code"
+  (mapcan 
+   #'(lambda (slot-name)
+       (when (slot-boundp object slot-name)
+	 
+	 (list (intern (symbol-name slot-name) 
+		       (find-package :keyword))
+	       (slot-value object slot-name))))
+   (list-slots object)))
+
+(defun properties-as-slots (plist)
+  "takes a plist and turns it into slot-definitions, interning the key names in *package*"
+  (loop for (key val) on plist by #'cddr
+	collect (let ((name (intern (symbol-name key))))
+		  `(,name :accessor ,name :initarg ,key :special t :initform ,val))))
+
+(defmacro with-properties ((properties &optional (prefix '||))  &body body)
+  (with-unique-names (p)
+    (let ((get (intern (strcat prefix '.get)))
+	  (set (intern (strcat prefix '.set)))
+	  (props (intern (strcat prefix '.properties))))
+      `(let ((,p ,properties))
+	(flet ((,get  (p)
+		 (getf ,p p))
+	       (,set (p v)
+		 (setf (getf ,p p) v))
+	       (,props ()
+		 ,p))
+	  (declare (ignorable #',get #',set #',props))
+	  ,@body)))))
\ No newline at end of file
diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp
index 75d04f8..2566023 100644
--- a/src/relational-attributes.lisp
+++ b/src/relational-attributes.lisp
@@ -2,23 +2,54 @@
 
 ;;;; * Relational Attributes
 
+
+;;;; ** has-a
+
+(defattribute has-a ()
+  ()
+  (:default-properties
+      :has-a nil))
+
+(define-layered-method attribute-value (object (attribute has-a))
+ (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))		       
+		       
+(defdisplay ((attribute has-a) object)
+  (let ((args (plist-union (description.properties attribute) (has-a attribute)))
+	(val (attribute-value object attribute)))
+    (when val
+      (setf (getf args :type)
+	    'lol::one-line))	    
+    (apply #'display* val
+	   args)))
+
+
 ;;;; ** Has-Many attribute
 
 (defattribute has-many ()
   ()
   (:default-properties
       :add-new-label "Add New"
-    :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x)))))
+    :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
+  (:default-initargs
+      :type 'lol::one-line))
+
 
+(define-layered-method
+    attribute-value (object (has-many has-many))
+  (slot-value object (slot-name has-many)))
 
-(defdisplay object (:description (attribute has-many))
+(defdisplay ((attribute has-many) object)
     ;
-  (<ucw:submit :action (add-to-has-many slot instance) :value (getp :add-new-label))
-  (let* ((i (apply #'sort (slot-value object (getp :slot-name))
-		  (getp :sort-arguments))))
-    (display component i
-	     :type'lol::one-line
-	     :layers '(+ wrap-link))))
+  ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
+	    
+ (<:div  :style "clear:both;"
+	 (let* ((i (apply #'sort (slot-value object (slot-name attribute))
+			  (sort-arguments attribute))))
+	   (<:ul 
+	    (dolist* (x i)
+	      (<:li (display* x
+			      :type 'lol::one-line
+			      :layers '(+ wrap-link - label-attributes))))))))
 
 
 (defun find-many-to-many-class (slot-name instance)
@@ -35,13 +66,13 @@
 
 
 
-(defdisplay object (:description (attribute many-to-many))
+(defdisplay ((attribute many-to-many) object)
   (<:as-html "ASDASD"))
 
   #+nil(let ((instances (select-instances object t))
 	new-instance)
     (<:ul
-     (<:li (<ucw:button :action (add-new-relation component object (getp slot-name))
+     (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
 			(<:as-html "Add New")))
      (<:li  (<ucw:button :action (add-new-relation component object new-instance)
 			 (<:as-html "Add:"))
@@ -57,5 +88,5 @@
 	(<ucw:a :action (delete-relationship slot (second i) instance)
 		(<:as-html "(remove) "))
 	(display component object)))))
-  ;(display component (mapcar #'car (slot-value object (getp :slot-name))))
+  ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
 		      
\ No newline at end of file
diff --git a/src/slot-presentations.lisp b/src/slot-presentations.lisp
index d515860..2f75737 100644
--- a/src/slot-presentations.lisp
+++ b/src/slot-presentations.lisp
@@ -217,11 +217,10 @@ Calendar.setup({
   ;; the viewed instance could have been changed/deleted, so we sync this instance
   (meta-model:sync-instance (instance (ucw::parent self))))
 
-
 (defmethod  present-slot :around ((slot foreign-key-slot-presentation) instance)  
   (setf (foreign-instance slot) 
 	(when (lol::presentation-slot-value slot instance) 
-	  (meta-model:explode-foreign-key instance (slot-name slot))))
+	  (meta-model:explode-foreign-key instance (slot-name slot) :nilp t)))
   (flet ((render () (when (foreign-instance slot)(call-next-method))))
     (if (slot-boundp slot 'ucw::place)
         (cond 
diff --git a/src/special-initargs.lisp b/src/special-initargs.lisp
new file mode 100644
index 0000000..5fffa46
--- /dev/null
+++ b/src/special-initargs.lisp
@@ -0,0 +1,38 @@
+(in-package :lisp-on-lines)
+
+(defmethod initargs.slot-names (object)
+  "Returns ALIST of (initargs) . slot-name."
+  (nreverse (mapcar #'(lambda (slot)
+	      (cons (closer-mop:slot-definition-initargs slot)
+		    (closer-mop:slot-definition-name slot)))
+	  (closer-mop:class-slots (class-of object)))))
+
+(defun find-slot-names-from-initargs-plist (object initargs-plist)
+  "returns (VALUES SLOT-NAMES VALUES), Given a plist of initargs such as one would pass to :DEFAULT-INITARGS.
+SLOT-NAMES contains the slot-names specified by the initarg, and VALUES the corresponding VALUE."
+  (let (slot-names values
+	(initargs.slot-names-alist (initargs.slot-names object))) 
+    (loop for (initarg value) on initargs-plist
+	  do (let ((slot-name
+		    (cdr (assoc-if #'(lambda (x) (member initarg x))
+				   initargs.slot-names-alist))))
+	       (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
+		 (push slot-name slot-names)
+		 (push value values)))
+	  finally (return (values slot-names values)))))
+
+(defun funcall-with-special-initargs (object initargs function &rest args)
+  "Call FUNCTION with dynnamic bindings of the slots in OBJECT specified by the INITARGS plist"
+  (multiple-value-bind (slot-names values)
+	(find-slot-names-from-initargs-plist object initargs)
+      (special-symbol-progv
+	  (with-symbol-access
+	    (loop for slot-name in slot-names
+		  collect (slot-value object slot-name)))
+	  values
+	(apply function args))))
+
+(defmacro with-special-initargs ((object &rest initargs) &body body)
+  `(funcall-with-special-initargs ,object ,initargs
+    #'(lambda ()
+	,@body)))
\ No newline at end of file
diff --git a/src/standard-attributes.lisp b/src/standard-attributes.lisp
dissimilarity index 68%
index 492a06b..87b8620 100644
--- a/src/standard-attributes.lisp
+++ b/src/standard-attributes.lisp
@@ -1,53 +1,168 @@
-(in-package :lisp-on-lines)
-
-;;;; Strings
-
-(defattribute string-attribute ()
-  ()
-  (:type-name string)
-  (:default-properties
-      :escape-html-p t))
-
-(defdisplay object (:description (string string-attribute))
-  (<:as-html "ASD")
-  (if (getp :escape-html-p)
-      (<:as-html (attribute-value object string))
-      (<:as-is (attribute-value object string))))
-
-
-(defattribute image ()
-  ())
-
-(defdisplay object (:description (buttons (eql 'image-editor-buttons)))
-  (<ucw:a :action (ok component object)
-	  (<:as-html "select this image")))
-
-(defdisplay object (:description (image image))
-  (<:img
-   :class (or (getp :css-class) "lol-image") 
-   :src (arnesi:strcat
-	 (or (getp :prefix) "images/")
-	 (escape-as-uri
-	  (attribute-value object image)))))
-
-(defdisplay object (:description (image image)
-	     :in-layer editor)
-  (<:div
-   :class "lol-image-thumbnails"
-   
-  (dolist* (i (or (getp :directory)
-		  (cl-fad:list-directory (strcat *default-pathname-defaults* "wwwroot/images/"))))
-    (<:div
-     :style "border: 1px solid black;width:100px;"
-     (<:img
-      :width "90px"
-      :src (strcat (or (getp :prefix) "images/")
-		   (file-namestring i)))
-     (display-using-description 'image-editor-buttons component (file-namestring i) properties))
-    (<:p :style "clear:both;"))))
-
-
-
-
-
-
+(in-package :lisp-on-lines)
+
+(deflayer omit-nil-attributes)
+
+(defdisplay :in-layer omit-nil-attributes
+	    :around ((attribute standard-attribute) object)
+ (when (attribute-value object attribute)
+   (call-next-method)))
+
+(deflayer label-attributes)
+
+(defdisplay :in-layer label-attributes
+	    :around ((attribute standard-attribute) object)
+
+    (<:span
+     :class "lol-label"
+     (<:as-html (or (label attribute) (attribute.name attribute))))
+    (<:span
+     :class "lol-attribute"
+     (call-next-method)))
+
+;;;; * Base Types
+
+(defattribute base-attribute ()
+  ())
+
+(defdisplay ((base base-attribute) object)
+ (<:as-html (attribute-value object base)))
+
+;;;; Strings
+
+(defattribute string-attribute (base-attribute)
+  ()
+
+  (:type-name string)
+  (:default-properties
+      :escape-html-p t
+    :size nil
+    :max-length nil))
+
+(defdisplay :in-layer omit-nil-attributes
+	    :around ((attribute string-attribute) object)
+ (when (< 0 (length  (attribute-value object attribute)))
+   (call-next-method)))
+
+
+;;;; default
+(defdisplay ((string string-attribute) object)
+  (if (escape-html-p string)
+      (<:as-html (attribute-value object string))
+      (<:as-is (attribute-value object string))))
+
+
+;;;; editor
+(defattribute string-attribute (base-attribute)
+  ()
+  (:in-layer editor)
+  (:default-properties
+      :callback nil))
+
+(defdisplay
+   :in-layer editor :around ((string string-attribute) object)
+ (dletf (((callback string) (ucw::make-new-callback
+			     #'(lambda (val)
+				 (setf (attribute-value object string) val)))))
+   (call-next-method)))
+
+(defdisplay :in-layer editor ((string string-attribute) object)
+ (<:input
+  :type "text"
+  :id (id string)
+  :name (callback string)
+  :value (or (attribute-value object string) "")))	    
+
+(defattribute string-search-attribute (string-attribute)
+  ()
+  (:default-properties
+      ;; the func that find search results
+
+      :search-action #'(lambda ()
+			 (with-call/cc 
+			   nil))
+    ;; when chosing from a list of results, this function selects one.
+    :select-function (constantly t))
+  (:type-name string-search))
+
+(defdisplay
+   :in-layer editor :after ((search string-search-attribute) object)
+     (IT.BESE.YACLML.TAGS:INPUT
+      :TYPE "submit"
+      :VALUE "search"
+      :ONCLICK
+      (JS:JS-INLINE*
+       `(PROGN
+	 (IT.BESE.UCW::SET-ACTION-PARAMETER
+	  ,(IT.BESE.UCW::MAKE-NEW-ACTION
+	    (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
+	    (search-action search)))
+	 (RETURN T)))))
+
+;;;; textarea
+
+(defattribute text-attribute (string-attribute)
+  ()
+  (:type-name text))
+
+(defdisplay :in-layer editor ((string text-attribute) object)
+ (<:textarea
+  :id (id string)
+  :name (callback string)
+ (or (attribute-value object string) "")))
+
+
+
+;;;; WALL-TIME
+
+(defattribute wall-time-attribute (string-attribute)
+  ()
+  (:type-name clsql-sys:wall-time))
+
+(define-layered-method attribute-value (object (attribute wall-time-attribute))
+ (let ((date (call-next-method)))
+   (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
+		(format nil "~a/~a/~a" m d y)))))
+		       
+(defdisplay
+  ((time wall-time-attribute) object)
+  (<:as-html (attribute-value object time)))
+
+
+
+(defattribute image ()
+  ())
+
+(defdisplay ((buttons (eql 'image-editor-buttons)) object)
+  (<ucw:a :action (ok component object)
+	  (<:as-html "select this image")))
+
+(defdisplay ((image image) object)
+  (<:img
+   :class (or (.get :css-class) "lol-image") 
+   :src (arnesi:strcat
+	 (or (.get :prefix) "images/")
+	 (escape-as-uri
+	  (attribute-value object image)))))
+
+(defdisplay
+    :in-layer editor ((image image)  object)
+
+    (<:div
+     :class "lol-image-thumbnails"
+   
+     (dolist* (i (or (.get :directory)
+		     (cl-fad:list-directory (strcat *default-pathname-defaults* "wwwroot/images/"))))
+       (<:div
+	:style "border: 1px solid black;width:100px;"
+	(<:img
+	 :width "90px"
+	 :src (strcat (or (.get :prefix) "images/")
+		      (file-namestring i)))
+	(display-using-description* 'image-editor-buttons (file-namestring i) (.properties)))
+       (<:p :style "clear:both;"))))
+
+
+
+
+
+
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
dissimilarity index 85%
index 9314196..1845491 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -1,164 +1,146 @@
-(in-package :lisp-on-lines)
-
-
-;;;; The Standard Layer Hierarchy
-(deflayer viewer)
-(deflayer editor (viewer))
-(deflayer creator (editor))
-
-;;;; 'Mixin' Layers
-(deflayer one-line)
-
-(deflayer wrap-form)
-
-(deflayer as-table)
-
-(define-attributes (contextl-default)
-  (:viewer viewer)
-  (:editor editor)
-  (:creator creator))
-
-
-(defmacro with-component ((component) &body body)
-  `(let ((self ,component))
-    (declare (ignorable self))
-    (flet ((display* (thing &rest args)
-	     (apply #'display ,component thing args))
-	   (display-using-description* (desc obj &optional props)
-	     (display-using-description desc ,component obj props)))
-      (declare (ignorable #'display* #'display-using-description*))
-      ,@body)))
-
-
-(define-layered-function find-display-type (object))
-
-(define-layered-method find-display-type (object)
-  'viewer)
-
-(define-layered-function find-display-layers (object))
-
-(define-layered-method find-display-layers (object)
-  "layered function"
-  nil)
-
-(defmacro call-display (component object &rest args)
-  `(call-component ,component (make-instance 'standard-display-component
-			 :display #'(lambda (component)
-				      (with-component (component)
-					(display ,component ,object ,@args))))))
-
-
-
-;;;; * Object displays.
-
-;;;; We like to have a label for attributes, and meta-model provides a default.
-(defdisplay label
-    (:description (d (eql 'attribute-label)))
-  (<:span
-   :class "label"
-   (<:as-html label)))
-
-
-(define-layered-function display (component object &rest args)
-  (:documentation
-   "Displays OBJECT in COMPONENT. 
-
- default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
-
-(define-layered-method display
-    ((component t) (object standard-object) &rest args &key layers (type 'viewer)  &allow-other-keys)
-  (let* ((occurence (find-occurence object))
-	 (properties (attribute.properties
-		 (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
-	 (layers (append (when type (loop for ty in (ensure-list type)
-					  nconc `(+ ,ty)))
-			 layers
-			 (getf properties :layers))))
-    (funcall-with-layers 
-     layers		 
-     #'display-using-description  occurence component object (plist-union args properties))))
-
-
-(define-layered-method display
-  ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)
-  (funcall-with-layers 
-   layers		 
-   #'display-using-description  t component object args))
-
-
-(define-layered-function display-using-description (description component object properties)
-  (:documentation
-   "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
-
-(define-layered-method display-using-description (description component object properties)
-  "The standard display simply prints the object"
-  (declare (ignore component properties description))
-  (<:as-html object))
-
-
-
-;;;; ** The default display
-
-
-
-;;;; ** One line
-(defdisplay object (:in-layer one-line)
-  "The one line presentation just displays the attributes with a #\Space between them"
-  (do-attributes* (attribute)
-	(display-current-attribute)
-	(<:as-html " ")))
- 
-;;;; ** as-table
-
-(defdisplay object (:in-layer as-table)
-  (<:table
-   (do-attributes* (a)
-     (<:tr
-      (<:td  (<:as-html (a-getp :label)))
-      (<:td (display-current-attribute))))))
-
-;;;; List Displays
-(defdisplay (list list) ()
-  (<:ul
-   (dolist* (item list)
-     (<:li  (apply #'display component item properties)))))
-
-;;;; Attributes 
-(defdisplay object (:in-layer
-	     editor
- 	     :description (attribute standard-attribute))
-    "Legacy editor using UCW presentations"
-    (warn "USING LEGACY EDITOR FOR ~A" (getf (find-properties attribute) :slot-name))
-  (let ((p (lol:make-view object :type :editor)))
-    (present-slot-view p (getf (find-properties attribute) :slot-name))))
-
-(define-layered-method display-using-description
-  ((attribute standard-attribute) component object properties)
-  (<:as-html (attribute.type attribute) " ")
-    
-  (<:as-html (attribute-value object attribute)))
-
-(defdisplay (button (eql 'standard-form-buttons))
-    (:description (description t))
-    (<ucw:submit :action (ok component)
-		 :value "Ok."))
-
-(defdisplay object (:in-layer wrap-form
-		       :combination :around)
-  (<ucw:form
-   :action (refresh-component component)
-   (call-next-method)
-   (display component 'standard-form-buttons)))
-
-
-(defcomponent standard-display-component ()
-  ((display-function :accessor display-function :initarg :display)))
-
-(defmethod render ((self standard-display-component))
-  (funcall (display-function self) self))
-
-
-       
-				     
-
-
+(in-package :lisp-on-lines)
+
+;;;; The Standard Layers
+(deflayer viewer)
+(deflayer editor)
+(deflayer creator)
+(deflayer one-line)
+(deflayer as-table)
+(deflayer as-string)
+
+(defdisplay
+  :in-layer as-string (d o)
+  (do-attributes (a d)
+    (display-attribute a o)
+    (<:as-is " ")))
+
+(defmethod list-slots (thing)
+  (list 'identity))
+
+
+;;;; TODO : this doesn't work
+
+(defaction call-display-with-context ((from component) object context &rest properties)
+  (call-component self (make-instance 'standard-display-component
+				      :context context
+				      :object object
+				      :args (if (cdr properties)
+						 properties
+						 (car properties)))))
+
+(defmacro call-display (component object &rest properties)
+  `(let ()
+    (call-display-with-context ,component ,object nil  ,@properties)))
+
+(defcomponent standard-display-component ()
+  ((context :accessor context :initarg :context)
+   (object :accessor object :initarg :object)
+   (args :accessor args :initarg :args)))
+
+(defmethod render ((self standard-display-component))
+  
+  (apply #'display self (object self) (args self)))
+
+
+;;;; * Object displays.
+
+;;;; We like to have a label for attributes, and meta-model provides a default.
+(defdisplay ((desc (eql 'label)) label)
+  (<:span
+   :class "label"
+   (<:as-html label)))
+
+;;;; TODO: all lisp types should have occurences and attributes defined for them.
+
+(defdisplay ((description t) lisp-value)
+  (<:as-html lisp-value))
+
+(defdisplay (description (object string))
+  (<:as-html object))
+
+(defdisplay (description object (component t))
+  "The default display for CLOS objects"
+  (print (class-name (class-of object)))
+  (dolist* (slot-name (list-slots object))
+  
+    (let ((boundp (slot-boundp object slot-name)))
+      (format t "~A~A : ~A" (strcat slot-name)
+	      (if boundp
+		  ""
+		  "(unbound)")
+	      (if boundp
+		  (slot-value object slot-name) "")))))
+
+(defdisplay ((description t) object)
+  "The default display for CLOS objects in UCW components"
+   (dolist* (slot-name (list-slots object))
+
+      (let ((boundp (slot-boundp object slot-name)))
+	(<:label :class "lol-label"
+		 (display-attribute 'label  (strcat slot-name))
+	(if boundp
+	    ""
+	    "(unbound)"))
+      (<:as-html
+       (if boundp
+	   (slot-value object slot-name) "")))))
+
+;;;; ** The default displays for objects with a MEWA occurence
+
+(defdisplay (description object)
+ (<:div
+  :class "lol-display"	    
+  (do-attributes (attribute description)
+    (<:div
+     :class "lol-attribute-row"
+     (display-attribute attribute object)))))
+
+;;;; ** One line
+(defdisplay
+    :in-layer one-line (description object) 
+    "The one line presentation just displays the attributes with a #\Space between them"
+    (do-attributes (attribute description)
+      (display-attribute attribute object)
+      (<:as-html " ")))
+ 
+;;;; ** as-table
+
+(defdisplay :in-layer as-table (description object) 
+  (<:table 
+   (do-attributes (a description)
+     (<:tr
+      (<:td  :class "lol-label" (<:as-html (label a)))
+      (<:td (display-attribute a object))))))
+
+;;;; List Displays
+(defdisplay (desc (list list))
+  (<:ul
+   (dolist* (item list)
+     (<:li  (display* item)
+	    (<:as-html item)))))
+
+;;;; Attributes 
+(defdisplay
+    :in-layer editor
+    ((attribute standard-attribute) object)
+    "Legacy editor using UCW presentations"
+    
+    (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
+
+(define-layered-method display-using-description
+  ((attribute standard-attribute) object component)
+  (with-component (component)
+    (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
+	    (<:as-html "*" )))
+  (<:as-html (attribute-value object attribute)))
+
+
+
+
+
+
+
+       
+				     
+
+
diff --git a/src/standard-occurence.lisp b/src/standard-occurence.lisp
new file mode 100644
index 0000000..bb2f686
--- /dev/null
+++ b/src/standard-occurence.lisp
@@ -0,0 +1,24 @@
+(in-package :lisp-on-lines)
+
+;;;; STRINGS
+
+(find-or-create-occurence 'string)
+
+(defmethod find-occurence ((string string))
+  (find-occurence 'string))
+
+(set-attribute 'string 'identity `(string :getter ,#'(lambda (x)
+						       (identity x))))
+(set-default-attributes 'string)
+
+;;;; LISTS
+
+(find-or-create-occurence 'list)
+
+(defmethod find-occurence ((list list))
+  (find-occurence 'list))
+
+(set-attribute 'list 'identity `(string :getter ,#'(lambda (x)
+						       (identity x))))
+(set-default-attributes 'string)
+
diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp
dissimilarity index 76%
index 70777d8..bb24876 100644
--- a/src/standard-wrappers.lisp
+++ b/src/standard-wrappers.lisp
@@ -1,28 +1,54 @@
-(in-package :lisp-on-lines)
-
-;;;;; Wrap a display in "back buttons"
-(deflayer wrap-back-buttons)
-
-(defdisplay object (:in-layer
-	     wrap-back-buttons
-	     :combination :around)
-  (<ucw:a :class "wiz-button previous" :action (ok component t)
-	  (<:as-html "Go Back"))
-  (<:div :style "clear:both;"
-	 (call-next-method))
-  (<ucw:a :class "wiz-button previous" :action (ok component t)
-	  (<:as-html "Go Back")))
-
-;;;; Wrap an object display in with a link to the object
-
-(deflayer wrap-link)
-
-(defdisplay object (:in-layer
-	     wrap-link
-	     :combination :around)
-  (let ((layers  (find-display-layers object)))
-    (<ucw:a :action (call-display self object
-				  :type (find-display-type object)
-				  :layers layers)
-				 
-	    (call-next-method))))
\ No newline at end of file
+(in-package :lisp-on-lines)
+
+;;;;; Wrap a display in "back buttons"
+(deflayer wrap-back-buttons)
+
+(defdisplay
+    :in-layer wrap-back-buttons :around
+    (description object)
+    
+    (<ucw:a :class "wiz-button previous" :action (ok component t)
+	    (<:as-html "Go Back"))
+    (<:div :style "clear:both;"
+	   (call-next-method))
+    (<ucw:a :class "wiz-button previous" :action (ok component t)
+	    (<:as-html "Go Back")))
+
+;;;; Wrap an object display in with a link to the object
+
+(deflayer wrap-link)
+
+(defvar *link-wrapped-p* nil)
+
+(define-layered-class description
+  :in-layer wrap-link ()
+  ((link :initarg :link :initform nil :special t :accessor link)))
+
+(defdisplay
+  :in-layer wrap-link :around (description object)
+  (let ((link (link description)))
+
+    (with-inactive-layers (wrap-link)
+      (if *link-wrapped-p*
+	  (call-next-method)
+	  (let ((*link-wrapped-p* t))
+	    (<ucw:a :action (call-display self object link)
+		    (call-next-method)))))))
+
+
+
+;;; wrap-a-form
+(deflayer wrap-form)
+
+(defdisplay ((description t) (button (eql 'standard-form-buttons)))
+  (<ucw:submit :action (ok self)
+	       :value "Ok."))
+
+(defdisplay :in-layer wrap-form :around (object description)
+  (<ucw:form
+   :action (refresh-component self)
+   (with-inactive-layers (wrap-form)
+
+     (call-next-method)
+     ;(display* 'standard-form-buttons)
+   )))
\ No newline at end of file
diff --git a/src/ucw-test-component.lisp b/src/ucw-test-component.lisp
index b5e3e73..bca8dc1 100644
--- a/src/ucw-test-component.lisp
+++ b/src/ucw-test-component.lisp
@@ -1,12 +1,14 @@
 (in-package :lisp-on-lines)
 
 ;;;; LoL CLOS Test Class
-(defclass/meta test-class ()
-  ((test-string :initform "test string" :type string))
+(defclass lol-test-class ()
+  ((test-string :initform "test string"))
   (:documentation "foo"))
 
-(define-attributes (test-class)
-  (test-string t :label "String :" :editablep t))
+(set-default-attributes 'lol-test-class)
+
+(define-attributes (lol-test-class)
+  (test-string t :label "String :"))
   
 (defcomponent test-component ()
   ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
-- 
2.20.1