Added new display system

darcs-hash:20051230133838-5417e-42f6b4d009720491e8b4fa95020c36b4e5aea1c9.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 31a352d..598a1f7 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -19,11 +19,20 @@
                                       (:file "lisp-on-lines")
                                       (:file "presentations")
                                       (:file "slot-presentations")
-                                      (:file "slot-presentations/date"))
+                                      (:file "slot-presentations/date")
+                                      (:file "standard-display")
+                                      (:file "relational-attributes"))
                          :serial t)
                 (:module :components
                          :pathname "src/components/"
                          :components ((:file "range-list")
-                                      (:file "ajax"))))
+                                      (:file "ajax")
+                                      (:file "dojo"))))
     :serial t
     :depends-on (:arnesi :ucw :meta-model :split-sequence :contextl :cl-ppcre))
+
+(defsystem :lisp-on-lines.example
+    :components (
+                (:file "reddit-example"))
+
+    :depends-on (:lisp-on-lines))

diff --git a/src/lisp-on-lines.lisp b/src/lisp-on-lines.lisp
index a5415ae..c58c938 100644 (file)
--- a/src/lisp-on-lines.lisp
+++ b/src/lisp-on-lines.lisp
@@ -8,8 +8,42 @@
 ;;;; or Meta-Model.
 
 ;;;; ** Initialisation
+(defmethod find-default-attributes ((object t))
+  "return the default attributes for a given object using the meta-model's meta-data"
+  (append (mapcar #'(lambda (s) 
+                     (cons (car s) 
+                           (gen-pslot 
+                            (if (meta-model:foreign-key-p object (car s))
+                                'foreign-key
+                                (cadr s))
+                            (string (car s)) (car s)))) 
+                 (meta-model:list-slot-types object))
+         (mapcar #'(lambda (s) 
+                     (cons s (append (gen-pslot 'has-many (string s) s) 
+                                     `(:presentation 
+                                       (make-presentation 
+                                        ,object 
+                                        :type :one-line)))))
+                 (meta-model:list-has-many object))
+         (find-default-presentation-attribute-definitions)))
+
+(defmethod set-default-attributes ((object t))
+  "Set the default attributes for MODEL"
+  (clear-attributes object)
+  (mapcar #'(lambda (x) 
+             (setf (find-attribute object (car x)) (cdr x)))
+         (find-default-attributes object)))
+
+;;;; This automagically initialises any meta model
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmethod meta-model::generate-base-class-expander :after (meta-model name args)
+    (set-default-attributes name)))
+
 ;;;; The following macros are used to initialise a set of database tables as LoL objects.
 
+
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun generate-define-view-for-table (table)
     "

diff --git a/src/mewa.lisp b/src/mewa.lisp
index 1dea1fe..850ece6 100644 (file)
--- a/src/mewa.lisp
+++ b/src/mewa.lisp
@@ -74,6 +74,17 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
      (plist :layered-accessor attribute.plist :initarg :plist :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."))
 
+(defmacro defattribute (name supers slots &rest args)
+  (let ((type (or (second (assoc :type-name args)) name) ))
+    `(progn
+      
+      (define-layered-class
+         ;;;; TODO: naive way of making sure s-a is a superclass
+         ,name ,(or supers '(standard-attribute))
+         ,slots
+         #+ (or) ,@ (cdr 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)
@@ -90,17 +101,24 @@ using the attributes defined in an occurence. Presentation Attributes are always
   "removes all attributes from an occurance"
   (clear-occurence (find-occurence name)))
 
+(defmethod find-attribute-class-for-type (type)
+  nil)
+
 (defmethod find-attribute-class-for-name (name)
   "presentation attributes are named using keywords"
   (if (keywordp name)
       'presentation-attribute
       'standard-attribute))
 
+(defun make-attribute (&key name type plist)
+  (make-instance (or (find-attribute-class-for-type type)
+                    (find-attribute-class-for-name name)) 
+                :name name :type type :plist plist))
+
 (defmethod ensure-attribute ((occurence standard-occurence) name type plist)
   "Creates an attribute in the given occurence"
   (setf (gethash name (attribute-map occurence))
-       (make-instance (find-attribute-class-for-name name)
-                      :name name :type type :plist plist)))
+       (make-attribute :name name :type type :plist plist)))
 
 (defmethod find-attribute ((occurence standard-occurence) name)
   (gethash name (attribute-map occurence)))
@@ -162,6 +180,7 @@ using the attributes defined in an occurence. Presentation Attributes are always
 
 
 (defmethod setter (attribute)
+  (warn "Setting ~A in ~A" attribute *context*)
   (let ((setter (getf (attribute.plist attribute) :setter))
        (slot-name (getf (attribute.plist attribute) :slot-name)))
     (cond (setter
@@ -183,13 +202,19 @@ using the attributes defined in an occurence. Presentation Attributes are always
               (when (slot-boundp object slot-name)
                 (slot-value object slot-name)))))))
 
-(defgeneric attribute-value (instance attribute)
-  (:method (instance (attribute standard-attribute))
-    (funcall (getter attribute) instance)))
 
-(defgeneric (setf attribute-value) (value instance attribute)
-  (:method (value instance (attribute standard-attribute))
-    (funcall (setter attribute) value instance)))
+(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))
+
+(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))
 
 
 ;;;; ** Default Attributes
@@ -261,31 +286,7 @@ using the attributes defined in an occurence. Presentation Attributes are always
               :label ,label
               :slot-name ,slot-name))) 
 
-(defmethod find-default-attributes ((model t))
-  "return the default attributes for a given model using the meta-model's meta-data"
-  (append (mapcar #'(lambda (s) 
-                     (cons (car s) 
-                           (gen-pslot 
-                            (if (meta-model:foreign-key-p model (car s))
-                                'foreign-key
-                                (cadr s))
-                            (string (car s)) (car s)))) 
-                 (meta-model:list-slot-types model))
-         (mapcar #'(lambda (s) 
-                     (cons s (append (gen-pslot 'has-many (string s) s) 
-                                     `(:presentation 
-                                       (make-presentation 
-                                        ,model 
-                                        :type :one-line)))))
-                 (meta-model:list-has-many model))
-         (find-default-presentation-attribute-definitions)))
-
-(defmethod set-default-attributes ((model t))
-  "Set the default attributes for MODEL"
-  (clear-attributes model)
-  (mapcar #'(lambda (x) 
-             (setf (find-attribute model (car x)) (cdr x)))
-         (find-default-attributes model)))
+
          
 ;;;presentations 
 (defcomponent mewa ()
@@ -334,10 +335,6 @@ using the attributes defined in an occurence. Presentation Attributes are always
   (mapcar #'class-name 
          (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
 
-(defun make-attribute (&rest props &key type &allow-other-keys)
-       (remf props :type)
-       (cons (gensym) (cons type props)))
-
 (defun make-presentation-for-attribute-list-item
     (occurence att-name plist parent-presentation &optional type)
   (declare (type list plist) (type symbol att-name))
@@ -481,8 +478,6 @@ in that object presentation."
   (render-on res (slot-value self 'body)))
 
 
-
-
 (defaction cancel-save-instance ((self mewa))
   (cond  
     ((meta-model::persistentp (instance self))

diff --git a/src/presentations.lisp b/src/presentations.lisp
index 901548a..b463210 100644 (file)
--- a/src/presentations.lisp
+++ b/src/presentations.lisp
@@ -200,8 +200,6 @@
 (defmethod find-default-criteria (c mewa-string-slot-presentation)
   'string-contains)
 
-
-
 (defmethod render-criteria ((res response) (s mewa-presentation-search))
   (setf (criteria-input s) "")
   (<:ul

diff --git a/src/slot-presentations.lisp b/src/slot-presentations.lisp
index 188db91..8dff900 100644 (file)
--- a/src/slot-presentations.lisp
+++ b/src/slot-presentations.lisp
@@ -239,7 +239,8 @@ Calendar.setup({
 
 
 (defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
-  (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))))
+  (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))
+               :order-by (car (list-keys (instance slot)))))
 
 
 
@@ -444,7 +445,7 @@ Calendar.setup({
                (<:as-html "(view) "))
        (<ucw:a :action (delete-relationship slot (second i) instance)
                (<:as-html "(remove) "))
-       (present-view ((car i) (list-view slot) (ucw::parent slot)))) ))))
+       (present-view ((car i) (list-view slot) (ucw::parent slot))))))))
 
 
 (defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)