From: Drew Crampsie <drewc@tech.coop>
Date: Thu, 2 Feb 2006 06:56:32 +0000 (-0800)
Subject: fix all the definitions affected by defdisplay refactoring
X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/87e47dd67949ba2d7e8e95912517d7d6366a303c

fix all the definitions affected by defdisplay refactoring

darcs-hash:20060202065632-5417e-3f875aa7db1e67d57b41a65862ee59ccacb4354f.gz
---

diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp
index 89a22c0..75d04f8 100644
--- a/src/relational-attributes.lisp
+++ b/src/relational-attributes.lisp
@@ -11,7 +11,7 @@
     :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x)))))
 
 
-(defdisplay (:description (attribute has-many))
+(defdisplay object (:description (attribute has-many))
     ;
   (<ucw:submit :action (add-to-has-many slot instance) :value (getp :add-new-label))
   (let* ((i (apply #'sort (slot-value object (getp :slot-name))
@@ -35,7 +35,7 @@
 
 
 
-(defdisplay (:description (attribute many-to-many))
+(defdisplay object (:description (attribute many-to-many))
   (<:as-html "ASDASD"))
 
   #+nil(let ((instances (select-instances object t))
diff --git a/src/standard-attributes.lisp b/src/standard-attributes.lisp
index d855e9d..1eb244f 100644
--- a/src/standard-attributes.lisp
+++ b/src/standard-attributes.lisp
@@ -3,11 +3,11 @@
 (defattribute image ()
   ())
 
-(defdisplay (:description (buttons (eql 'image-editor-buttons)))
+(defdisplay object (:description (buttons (eql 'image-editor-buttons)))
   (<ucw:a :action (ok component object)
 	  (<:as-html "select this image")))
 
-(defdisplay (:description (image image))
+(defdisplay object (:description (image image))
   (<:img
    :class (or (getp :css-class) "lol-image") 
    :src (arnesi:strcat
@@ -15,7 +15,7 @@
 	 (escape-as-uri
 	  (attribute-value object image)))))
 
-(defdisplay (:description (image image)
+(defdisplay object (:description (image image)
 	     :in-layer editor)
   (<:div
    :class "lol-image-thumbnails"
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
dissimilarity index 60%
index cc0b897..9314196 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -1,269 +1,164 @@
-(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))
-    (flet ((display* (thing &rest args)
-	     (apply #'display ,component thing args)))
-      ,@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))))))
-
-(defmethod find-plist (object)
-  (list))
-
-(defmethod find-plist ((attribute standard-attribute))
-  (warn "atttributre plist ~A" (attribute.plist attribute))
-  (attribute.plist attribute))
-
-(defmacro with-plist ((plist-form &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 ,plist-form))
-	(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 plist type)
-    `(loop for ,att in ,attributes
-      do (let* ((,att (ensure-list ,att))
-		(,plist (rest ,att))
-		(,type (getf ,plist :type))
-		(,var (if ,type
-			  (make-attribute :name (first ,att) :type ,type :plist ,plist)
-			  (find-attribute ,occurence (first ,att)))))
-	   (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var)	   
-	     ,@body)))))
-
-
-(defmacro defdisplay ((&key
-		       (in-layer nil layer-supplied-p)
-		       (combination nil combination-supplied-p)
-		       (description '(occurence standard-occurence) description-supplied-p)
-		       (component 'component)
-		       ((:class object)  nil))
-		      &body body)
-  (let ((class-spec (if object (if (listp object) object (list object object)) 'object)))
-  `(define-layered-method display-using-description
-    ,@(when layer-supplied-p `(:in-layer ,in-layer))
-    ,@(when combination-supplied-p `(,combination))
-    (,description ,component
-     ,class-spec  properties)
-    
-
-    (with-plist ((plist-union properties (find-plist ,(car description))))
-      
-      ,(if (not description-supplied-p)
-	   `(flet ((attributes ()
-		    (or (getp :attributes)
-			(list-slots ,(car (ensure-list class-spec))))))
-	     (declare (ignorable #'attributes))
-	     
-	     ,@body)
-	   `(progn ,@body))))  )
-  )
-
-
-(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))
-	 (plist (attribute.plist
-		 (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
-	 (layers (append (when type (loop for ty in (ensure-list type)
-					  nconc `(+ ,ty)))
-			 layers
-			 (getf plist :layers))))
-    (funcall-with-layers 
-     layers		 
-     #'display-using-description  occurence component object (plist-union args plist))))
-
-
-(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))
-
-;;;; * Object Presentations
-(define-layered-method display-using-description
-  ((occurence standard-occurence) component object properties)
-
-  (with-plist (properties o)
-    (loop for att in (or (o-getp :attributes) (list-slots object))
-	  do (let* ((att (ensure-list att))
-		    (attribute (find-attribute occurence (first att))))
-	       (with-plist ((plist-union (rest att) (find-plist attribute)))
-		 (<:p :class "attribute"
-		      (and (o-getp :show-labels-p)
-			   (<:span :class "label" (<:as-html (or (getp :label) "")  " ")))	   
-		      (display-using-description
-		       attribute
-		       component
-		       object
-		       (rest att))))))))
-
-
-
-
-;;;; ** One line
-(defdisplay (:in-layer one-line)
-  "The one line presentation just displays the attributes with a #\Space between them"
-  (do-attributes (attribute occurence (or (getp :attributes)
-					  (list-slots object)))
-	(display-using-description attribute component object (attribute-properties))
-	(<:as-html " ")))
- 
-;;;; ** as-table
-
-(defdisplay (:in-layer as-table)
-  (<:table
-   (do-attributes (a occurence (attributes))
-     (<:tr
-      (<:td  (<:as-html (a-getp :label)))
-      (<:td (display-using-description a component object (a-properties)))))))
-
-;;;; List Displays
-(defdisplay (:class
-	     (list list)
-	     :description (desc t))
-  (<:ul
-   (dolist* (item list)
-     (<:li  (apply #'display component item properties)))))
-
-
-
-;;;; Attributes 
-(defdisplay (:in-layer
-	     editor
- 	     :description (attribute standard-attribute))
-    "Legacy editor using UCW presentations"
-  (let ((p (lol:make-view object :type :editor)))
-    (present-slot-view p (getf (find-plist attribute) :slot-name))))
-
-(define-layered-method display-using-description
-    ((attribute standard-attribute) component object properties)
-  (let ((p (lol:make-view object :type 'mewa-viewer))
-	(name (attribute.name attribute)))
-    (when name (present-slot-view p name))))
-
-(defdisplay (:class
-	     (button (eql 'standard-form-buttons))
-	     :description (description t))
-    (<ucw:submit :action (ok component)
-		 :value "Ok."))
-
-(defdisplay (:in-layer wrap-form
-		       :combination :around)
-  (<ucw:form
-   :action (refresh-component component)
-   (call-next-method)
-   (display component 'standard-form-buttons)))
-
-
-(defclass/meta test-class ()
-  ((test-string :initform "test string" :type string))
-  (:documentation "foo"))
-
-(define-attributes (test-class)
-  (test-string t :label "String :" :editablep t))
-  
-(defcomponent test-component ()
-  ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
-   (current-type :accessor current-type :initform 'viewer)
-   (instance :accessor instance :initform (make-instance 'test-class))))
-
-(defmethod render ((self test-component))
-  (let ((test (instance self))) 
-    (<:h1 (<:as-html "Lisp on Lines Test Component"))
-    (with-component (self)
-      (<ucw:form
-       :action (refresh-component self)
-       (<ucw:select :accessor (current-type self)
-		    (dolist* (type (display-types self))
-		      (<ucw:option :value type (<:as-html type))))
-       (<:input :type "Submit" :value "update")
-       (<:fieldset
-	(<:legend (<:as-html (current-type self)))
-	(display test :type (current-type self)))))
-
-    (<:div
-     (<:h2
-      (<:as-html "UCW Presentation based displays (the old school"))
-     (dolist (type '(:viewer :editor :creator :one-line :as-string))
-       (<:h3 (<:as-html type))
-       (present-view (test type self))
-       (<ucw:a :action (call-view (test type self))
-	       (<:as-html "Call to " type))))))
-
-
-(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 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))
+
+
+       
+				     
+
+
diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp
index e0f44f6..70777d8 100644
--- a/src/standard-wrappers.lisp
+++ b/src/standard-wrappers.lisp
@@ -3,7 +3,7 @@
 ;;;;; Wrap a display in "back buttons"
 (deflayer wrap-back-buttons)
 
-(defdisplay (:in-layer
+(defdisplay object (:in-layer
 	     wrap-back-buttons
 	     :combination :around)
   (<ucw:a :class "wiz-button previous" :action (ok component t)
@@ -17,11 +17,11 @@
 
 (deflayer wrap-link)
 
-(defdisplay (:in-layer
+(defdisplay object (:in-layer
 	     wrap-link
 	     :combination :around)
   (let ((layers  (find-display-layers object)))
-    (<ucw:a :action (call-display component object
+    (<ucw:a :action (call-display self object
 				  :type (find-display-type object)
 				  :layers layers)