From fb04c0a8c71cd64e3a36cfed59a0224d44de2474 Mon Sep 17 00:00:00 2001
From: drewc <drewc@tech.coop>
Date: Thu, 3 Aug 2006 10:29:28 -0700
Subject: [PATCH] reorganized some source files

darcs-hash:20060803172928-39164-f221a842ae3c21e40146032d680db4ea47b19506.gz
---
 reddit-example.lisp                       |  2 +-
 src/attributes/numbers.lisp               | 21 +++++---
 src/attributes/relational-attributes.lisp | 30 +++++++----
 src/attributes/standard-attributes.lisp   | 28 ++++++++--
 src/defdisplay.lisp                       | 32 +++++++++--
 src/mewa.lisp                             | 65 +++++++++++------------
 src/standard-display.lisp                 | 26 ++++++++-
 src/standard-occurence.lisp               |  1 -
 src/standard-wrappers.lisp                | 12 +++--
 9 files changed, 149 insertions(+), 68 deletions(-)

diff --git a/reddit-example.lisp b/reddit-example.lisp
index 47ce250..1efa49d 100644
--- a/reddit-example.lisp
+++ b/reddit-example.lisp
@@ -2,7 +2,7 @@
 
 (defvar *lol-example-application*
   (make-instance 'cookie-session-application
-                 :url-prefix "/"
+                 :url-prefix "/lisp-on-lines/"
                  :tal-generator (make-instance 'yaclml:file-system-generator
                                                :cachep t
                                                :root-directories (list *ucw-tal-root*))
diff --git a/src/attributes/numbers.lisp b/src/attributes/numbers.lisp
index 520e621..45d8aaa 100644
--- a/src/attributes/numbers.lisp
+++ b/src/attributes/numbers.lisp
@@ -45,11 +45,20 @@
   (:type-name currency))
 
 
-(defdisplay :in-layer editor
+(defdisplay
+  :in-layer t
    ((currency currency-attribute) object)
-    (<:as-html "$")
+
+   (<:as-html (format nil "$~$" (or (attribute-value object currency) ""))))
+
+(defdisplay
+  :in-layer editor
+  ((currency currency-attribute) object)
+    (LET ((value (attribute-value (object currency) currency)))
     (<:input
-     :type "text"
-     :id (id currency)
-     :name (callback currency)
-     :value (format nil "~$" (or (attribute-value object currency) ""))))
+     :NAME
+     (callback currency)
+     :VALUE (escape-as-html (strcat (display-value currency value)))
+     :TYPE
+     "text"))
+  )
diff --git a/src/attributes/relational-attributes.lisp b/src/attributes/relational-attributes.lisp
index 2b7cdbf..de3fcc2 100644
--- a/src/attributes/relational-attributes.lisp
+++ b/src/attributes/relational-attributes.lisp
@@ -3,10 +3,21 @@
 ;;;; * Relational Attributes
 
 
+(defvar *parent-relations* nil)
+
 ;;;; ** has-a
 ;;;; Used for foreign keys, currently only works with clsql.
 
-(defattribute has-a ()
+(defattribute relational-attribute ()
+  ())
+
+(defdisplay :wrap-around ((attribute relational-attribute) object)
+	    (print (cons "parent-r" *parent-relations*))
+ (dletf (((value attribute) (attribute-value object attribute)))
+   (unless (find (value attribute) *parent-relations* :test #'meta-model::generic-equal)
+     (call-next-method))))
+
+(defattribute has-a (relational-attribute)
   ()
   (:default-properties
       :has-a nil
@@ -27,8 +38,6 @@
   (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
     (setf (attribute-value object attribute) val)))
 
-
-
 (define-layered-function find-all-foreign-objects (o a))
 
 (define-layered-method find-all-foreign-objects (object (attribute has-a))
@@ -39,7 +48,7 @@
 	(val (attribute-value object attribute)))
     (when val
       (setf (getf args :type)
-	    'lol::one-line))	    
+	    'lol::one-line))
     (apply #'display* val
 	   args)))
 
@@ -55,13 +64,13 @@
      :value obj
      (display* obj :layers '(+ as-string))))))
 
-
 ;;;; ** Has-Many attribute
 
 (defattribute has-many ()
   ()
   (:default-properties
       :add-new-label "Add New"
+    :has-many nil
     :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
   (:default-initargs
       :type 'lol::one-line))
@@ -70,18 +79,17 @@
     attribute-value (object (has-many has-many))
     (slot-value object (slot-name has-many)))
 
+
 (defdisplay ((attribute has-many) object)
     ;
   ;(<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::as-string
-			      :layers '(+ wrap-link - label-attributes))))))))
+			  (sort-arguments attribute)))
+		(*parent-relations* (cons object *parent-relations*)))
+
+	   (apply #'display* i (has-many attribute)))))
 
 
 (defun find-many-to-many-class (slot-name instance)
diff --git a/src/attributes/standard-attributes.lisp b/src/attributes/standard-attributes.lisp
index dcd6196..8b739ab 100644
--- a/src/attributes/standard-attributes.lisp
+++ b/src/attributes/standard-attributes.lisp
@@ -13,7 +13,7 @@
 (defdisplay
     :in-layer show-attribute-labels
     :around ((attribute standard-attribute) object)    
-  (<:span
+  (<:label
    :class "lol-label"
    (<:as-html (or (label attribute) (attribute.name attribute)) " "))
   (<:span
@@ -82,6 +82,24 @@
 	 :attributes (attributes group)
 	 (group group)))
 
+
+(defattribute select-attribute (display-attribute)
+  ()
+  (:default-properties
+    :test 'meta-model::generic-equal
+    :options-getter (constantly nil))
+  (:type-name select))
+
+(defdisplay ((attribute select-attribute) object)
+ (<ucw:select
+  :accessor (attribute-value object attribute)
+
+  :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 ()
@@ -92,13 +110,15 @@
 (defdisplay ((base base-attribute) object)
  (<:as-html (attribute-value object base)))
 
-(defattribute base-attribute (ucw::string-field)
+(defattribute base-attribute ()
   ()
   (:in-layer editor)
   (:default-properties 
     :callback nil
     :default-value nil
-    :default-value-predicate #'null))
+    :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)
@@ -118,7 +138,7 @@
      :ID
      (DOM-ID FIELD)
      :SIZE
-     (ucw::INPUT-SIZE FIELD))))
+     (INPUT-SIZE FIELD))))
 
 (defdisplay
     :in-layer editor :around ((string base-attribute) object)
diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index 8dac5be..cb50cf5 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -11,9 +11,33 @@
     display-using-description (d o c)
     (<:as-html "default :" o))
 
-(defmethod find-layer-for-type (type)
-  type)
-
+(defun make-display-function (component object
+			      &rest properties
+			      &key type (line #'line-in)
+			      &allow-other-keys)
+  "returns a function that expects a 3 argument function as its argument
+
+The function (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
+
+  (lambda (function)
+    (let* ((description (find-occurence object)))
+
+      (if description
+	  (dletf (((description.type description) type)
+		  ((attributes description) (or
+					     (attributes description)
+					     (list-slots object))))
+	    ;; apply the default line to the description
+	    (funcall-with-description
+	     description
+	     (funcall line object)
+	     ;; apply the passed in arguments and call display-using-description
+	     #'(lambda ()		 
+		 (funcall-with-description
+		  description
+		  properties
+		  function description object component))))
+	  (error "no description for ~A" object)))))
 
 (define-layered-function display (component object &rest args)
   (:documentation
@@ -76,8 +100,6 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
 		  (apply function args))))))
       (apply function args)))
 
-
-
 (defmacro with-description ((description &rest properties) &body body)
   `(funcall-with-description ,description (if ',(cdr properties)
 					       (list ,@properties)
diff --git a/src/mewa.lisp b/src/mewa.lisp
index 25c8f07..8ec2a8a 100644
--- a/src/mewa.lisp
+++ b/src/mewa.lisp
@@ -1,9 +1,5 @@
-(declaim (optimize (speed 2) (space 3) (safety 0)))
-
 (in-package :lisp-on-lines)
 
-(defparameter *default-type* :ucw)
-
 (define-layered-class description ()
   ((description-type
     :initarg :type
@@ -18,7 +14,8 @@
    (description-properties
     :accessor description.properties
     :initform nil
-    :special t)
+    :special t
+    :documentation "TODO: not used much anymore, and shouldn't be relied on")
    (described-object
     :layered-accessor object
     :initform nil
@@ -32,8 +29,27 @@
     :accessor attributes
     :initarg :attributes
     :initform nil
+    :special t)
+   (description-default-properties
+    :accessor default-properties
+    :initarg :default-properties
+    :initform '()
     :special t)))
 
+(defmethod attributes :around ((description description))
+  "Add any default properties to the attributes"
+  
+  (let ((default-properties (default-properties description)))
+    (if (and (listp default-properties)
+	     (not (null default-properties)))
+	(let ((a (mapcar #'(lambda (att)
+		    (append (ensure-list att) default-properties))
+		(call-next-method))))
+	  
+
+	  a) 
+	(call-next-method))))
+
 (defmethod print-object ((self description) stream)
   (print-unreadable-object (self stream :type t)
     (with-slots (description-type) self
@@ -85,6 +101,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
      (occurence :accessor occurence :initarg :occurence :initform nil)
      (label :initarg :label :layered-accessor label :initform nil :special t)))
 
+
 ;;;; * Attributes
 (defmethod print-object ((self attribute) stream)
   (print-unreadable-object (self stream :type t)
@@ -99,6 +116,9 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
      (slot-name :accessor slot-name :initarg :slot-name :special t :initform nil))
     (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
 
+(define-layered-method label :around ((attribute standard-attribute))
+ (or (call-next-method) (attribute.name attribute)))
+
 (defmacro defattribute (name supers slots &rest args)
   (let* (
 	(type-provided-p (second (assoc :type-name args)))
@@ -129,11 +149,6 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
 	     (not (find-attribute-class-for-type name)))
 	 `(defmethod find-attribute-class-for-type ((type (eql ',type)))
 	   ',name)))))
-(define-layered-class
-    display-attribute (attribute)
-    ()
-    (:documentation "Presentation Attributes are used to display objects 
-using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
 
 (defun clear-attributes (name)
   "removes all attributes from an occurance"
@@ -175,7 +190,7 @@ using the attributes defined in an occurence. Presentation Attributes are always
 
 (defmethod find-all-attributes ((occurence standard-occurence))
   (loop for att being the hash-values of (attribute-map occurence)
-	collect att))
+     collect att))
 
 (defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
   (declare (ignore name type))
@@ -210,7 +225,6 @@ ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
   (setf (gethash attribute-name (attribute-map occurence))
 	  attribute))
 
-
 (defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
   (find-attribute (occurence attribute-with-occurence) attribute-name))
 
@@ -258,15 +272,10 @@ otherwise, (setf find-attribute)"
     ,@(loop for occurence-name in occurence-names
 	    collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
 
-(defmethod find-display-attribute (occurence name)
-  (find-attribute occurence (intern (symbol-name name) "KEYWORD")))
 
 (defmethod find-description (object type)
   (let ((occurence (find-occurence object)))
-    (or (find-display-attribute
-	 occurence
-	 type)
-	occurence)))
+	occurence))
 
 ;;"Unused???"
 (defmethod setter (attribute)
@@ -338,8 +347,8 @@ we return slot-value-or nil either boundp or not."
 
 
 ;;;; ** Default Attributes
-
-
+;;;; TODO: This is mosty an ugly hack and should be reworked.
+;;;; 
 ;;;; The default mewa class contains the types use as defaults.
 ;;;; maps meta-model slot-types to slot-presentation
 
@@ -356,12 +365,7 @@ we return slot-value-or nil either boundp or not."
   (integer   integer)
   (currency  currency)
   (clsql:generalized-boolean boolean)
-  (foreign-key foreign-key))
-
-(defun find-presentation-attributes (occurence-name)
-  (loop for att in (find-all-attributes occurence-name)
-	when (typep att 'display-attribute)
-	 collect att))
+  (foreign-key has-a))
 
 (defun attribute-to-definition (attribute)
   (nconc (list (attribute.name attribute)
@@ -369,13 +373,8 @@ we return slot-value-or nil either boundp or not."
 	 (description.properties attribute)))
 
 (defun find-default-presentation-attribute-definitions ()
-  (if (eql *default-attributes-class-name* 'default)
-      (mapcar #'attribute-to-definition (find-presentation-attributes 'default)) 
-      (remove-duplicates (mapcar #'attribute-to-definition
-				 (append
-				  (find-presentation-attributes 'default)
-				  (find-presentation-attributes
-				   *default-attributes-class-name*))))))
+  nil)
+
 (defun gen-ptype (type)
   (let* ((type (if (consp type) (car type) type))
 	 (possible-default (find-attribute *default-attributes-class-name* type))
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index bc1297c..35d57e1 100644
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -10,7 +10,8 @@
 (defdisplay
     :in-layer editor :around (description object)
   "It is useful to remove the viewer layer when in the editing layer.
-This allows us to dispatch to a subclasses editor."
+This allows us to dispatch to a subclasses editor.
+"
   (with-inactive-layers (viewer)
     (call-next-method)))
 
@@ -108,7 +109,11 @@ This allows us to dispatch to a subclasses editor."
 
 (define-layered-class description
   :in-layer list-display-layer ()
-  ((list-item :initarg :list-item :initform nil :special t :accessor list-item)))
+  ((list-item :initarg :list-item
+	      :initarg :table-item
+	      :initform nil
+	      :special t
+	      :accessor list-item)))
 
 (defdisplay (desc (list list))
  (with-active-layers (list-display-layer)
@@ -116,6 +121,23 @@ This allows us to dispatch to a subclasses editor."
     (dolist* (item list)
       (<:li  (apply #'display* item (list-item desc)))))))
 
+(defdisplay :in-layer as-table (description (list list))
+  (with-active-layers (list-display-layer)
+    (let ((item-description (find-occurence (first list))))
+      (<:table
+	(funcall
+	 (apply #'lol::make-display-function self (first list)
+		(list-item description))
+	 (lambda (desc item component)
+	   (<:tr
+	    (do-attributes (a desc)
+	      (<:th (<:as-html (label a)))))
+	   
+	   (dolist* (obj list)
+	     (<:tr 
+	      (do-attributes (a desc)
+		(<:td (display-attribute a obj)))))))))))
+
 ;;;; Attributes 
 (defdisplay
     :in-layer editor
diff --git a/src/standard-occurence.lisp b/src/standard-occurence.lisp
index eeef240..bb2f686 100644
--- a/src/standard-occurence.lisp
+++ b/src/standard-occurence.lisp
@@ -1,4 +1,3 @@
-
 (in-package :lisp-on-lines)
 
 ;;;; STRINGS
diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp
index d902eb3..690ac6d 100644
--- a/src/standard-wrappers.lisp
+++ b/src/standard-wrappers.lisp
@@ -31,7 +31,7 @@
 	 :initarg :action
 	 :initform nil :special t :accessor link-action)))
 
-(defaction call-action-with--component-and-object ((self component) action-id object)
+(defaction call-action-with-component-and-object ((self component) action-id object)
   (funcall (ucw::find-action (ucw::context.current-frame *context*) action-id)
 	   self
 	   object))
@@ -44,7 +44,7 @@
 	(if *link-wrapped-p*
 	    (call-next-method)
 	    (let ((*link-wrapped-p* t))
-	      (<ucw:a :action (call-action-with--component-and-object
+	      (<ucw:a :action (call-action-with-component-and-object
 			       self
 			       (ucw::make-new-action
 				(ucw::context.current-frame *context*)
@@ -66,17 +66,19 @@
 
 (defdisplay ((description form-button-attribute) object)	    
   (macrolet ((submit (&key action value )
-	       `(<ucw::simple-submit
+	       `(<ucw::value-submit
 		 :action (funcall ,action self object)
 		 
-		 (<:as-html ,value))))
+		 :value ,value)))
     (loop for button in (form-buttons description)
 	 do 
 	 (let ((button button))
 	   (with-properties (button)
 	     (let ((action (.get :action)))
 	       (submit :value (.get :value)
-		       :action action)))))))
+		       :action (if (consp action)
+				   (eval action)
+				   action))))))))
 
 
 
-- 
2.20.1