From 6f63d3a4f93eb311344748b5698a63ce42dd1813 Mon Sep 17 00:00:00 2001 From: Drew Crampsie Date: Fri, 30 Dec 2005 05:38:38 -0800 Subject: [PATCH 1/1] Added new display system darcs-hash:20051230133838-5417e-42f6b4d009720491e8b4fa95020c36b4e5aea1c9.gz --- lisp-on-lines.asd | 13 ++++++- src/lisp-on-lines.lisp | 34 +++++++++++++++++ src/mewa.lisp | 73 +++++++++++++++++-------------------- src/presentations.lisp | 2 - src/slot-presentations.lisp | 5 ++- 5 files changed, 82 insertions(+), 45 deletions(-) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index 31a352d..598a1f7 100644 --- 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 --- 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 --- 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 --- 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 --- 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) ")) (