From 0386c736fe19db9f72a9d12728f5707cf570778f Mon Sep 17 00:00:00 2001 From: drewc Date: Sat, 6 May 2006 15:54:38 -0700 Subject: [PATCH] add support for lines to default display darcs-hash:20060506225438-39164-155d1485a29d143fc6df56a7386e24fd50326d51.gz --- src/defdisplay.lisp | 68 +++++---- src/lines.lisp | 11 +- src/lisp-on-lines.lisp | 66 ++------ src/mewa.lisp | 271 ++------------------------------- src/packages.lisp | 14 ++ src/relational-attributes.lisp | 4 +- 6 files changed, 85 insertions(+), 349 deletions(-) diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp index 9b4cb79..ae74b8c 100644 --- a/src/defdisplay.lisp +++ b/src/defdisplay.lisp @@ -20,36 +20,46 @@ (define-layered-method display ((component t) (object t) &rest properties - &key type + &key type (line #'line-in) &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)))) + " The default display dispatch method + + DISPLAY takes two required arguments, + COMPONENT : The component to display FROM (not neccesarily 'in') + OBJECT : The 'thing' we want to display... in this case it's the component + + DISPLAY also takes keywords arguments which modify the DESCRIPTION, + that is to say the parameters that come together to create the output. + +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) + ((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 + #'display-using-description description object component)))) + (error "no description for ~A" object)))) ;;;;; Macros (defun funcall-with-description (description properties function &rest args) + (if description (dletf* (((description.type description) (or (getf properties :type) @@ -58,7 +68,7 @@ ((description.layers description) (append (description.layers description) (getf properties :layers))) - ((description.properties description) properties)) + ((description.properties description) (append (description.properties description) properties))) (funcall-with-layers (description.layers description) #'(lambda () @@ -114,14 +124,18 @@ (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) + (destructuring-bind (description &optional object component) (car tail) (with-unique-names (d c) (let (standard-description-p) `(define-layered-method display-using-description :in-layer ,layer ,@qualifiers - + + ,@(unless object + (setf object description) + (setf description d) + nil) (,(cond ((listp description) (setf d (car description)) diff --git a/src/lines.lisp b/src/lines.lisp index 209271f..8b26923 100644 --- a/src/lines.lisp +++ b/src/lines.lisp @@ -21,13 +21,16 @@ ,(or (cdr docstring-and-body) (car docstring-and-body))))) - -(defun line-out (component object &key (line #'line-in) args) +(defun line-out (component object &rest args &key (line #'line-in) &allow-other-keys ) (apply #'display component object (append args (funcall line object)))) +(defline line-in (thing) + '()) + + (defmacro call-line (from line &rest args) (with-unique-names (lines object) `(multiple-value-bind (,lines ,object) - (funcall ,line) - (call-display-with-context ,from ,object nil (append ,args ,lines))))) + (funcall ,line) + (call-display-with-context ,from ,object nil (append ,args ,lines))))) diff --git a/src/lisp-on-lines.lisp b/src/lisp-on-lines.lisp index 3c02bd9..7bc4040 100644 --- a/src/lisp-on-lines.lisp +++ b/src/lisp-on-lines.lisp @@ -7,6 +7,13 @@ ;;;; that are part of LoL proper, that is to say, not Mewa ;;;; or Meta-Model. + + +(defmacro action (args &body body) + `(lambda ,args + (with-call/cc + ,@body))) + ;;;; ** Initialisation (defmethod find-default-attributes ((object t)) "return the default attributes for a given object using the meta-model's meta-data" @@ -42,7 +49,6 @@ ;;;; 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) " @@ -50,8 +56,8 @@ Generates a form that, when evaluated, initialises the given table as an lol obj This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation" `(progn - (def-view-class-from-table ,table) - (set-default-attributes (quote ,(meta-model::sql->sym table)))))) + (def-view-class-from-table ,table) + (set-default-attributes (quote ,(meta-model::sql->sym table)))))) (defmacro define-view-for-table (&rest tables) " expand to a form which initialises TABLES for use with LOL" @@ -64,60 +70,6 @@ This involves creating a meta-model, a clsql view-class, and the setting up the `(define-view-for-table ,@(meta-model::list-tables))) - -;;;; These are some macros over the old presentation system. -;;;; Considered depreciated, they will eventually be implemented in terms of the new -;;;; display system, and delegated to backwards-compat-0.2.lisp - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun %make-view (object type attributes args) - - (when attributes - (setf args - (cons `(:attributes ,attributes) args))) - `(mewa::make-presentation - ,object - :type ,type - ,@(when args - `(:initargs - '(,@ (mapcan #'identity args))))))) - -(defmethod make-view (object &rest args &key (type :viewer) - &allow-other-keys ) - (remf args :type) - ;(warn "~A ~A" args `(:type ,type :initargs ,@args)) - (apply #'make-presentation object `(:type ,type ,@ (when args - `(:initargs ,args))))) - -(defmacro present-view ((object &optional (type :viewer) (parent 'self)) - &body attributes-and-args) - (arnesi:with-unique-names (view) - `(let ((,view (lol::make-view ,object - :type ,type - ,@(when (car attributes-and-args) - `(:attributes ',(car attributes-and-args))) - ,@ (cdr attributes-and-args)))) - (setf (ucw::parent ,view) ,parent) - (lol::present ,view)))) - - -(defmacro call-view ((object &optional (type :viewer) (component 'self component-supplied-p)) - &body attributes-and-args) - `(ucw:call-component - ,component - ,(%make-view object type (car attributes-and-args) (cdr attributes-and-args)))) - -(defmethod slot-view ((self mewa) slot-name) - (mewa::find-attribute-slot self slot-name)) - -(defmethod present-slot-view ((self mewa) slot-name &optional (instance (instance self))) - (let ((v (slot-view self slot-name))) - - (if v - (present-slot v instance) - (<:as-html slot-name)))) - - (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" diff --git a/src/mewa.lisp b/src/mewa.lisp index 7c712ef..98c8135 100644 --- a/src/mewa.lisp +++ b/src/mewa.lisp @@ -19,6 +19,10 @@ :accessor description.properties :initform nil :special t) + (described-object + :layered-accessor object + :initform nil + :special t) (description-attributes :accessor attributes :initarg :attributes @@ -68,12 +72,12 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (define-layered-class attribute (description) - ((name :layered-accessor attribute.name + ((attribute-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))) + (label :initarg :label :layered-accessor label :initform nil :special t))) ;;;; * Attributes (defmethod print-object ((self attribute) stream) @@ -90,7 +94,9 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (: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)) + (let* ( + (type-provided-p (second (assoc :type-name args))) + (type (or type-provided-p name)) (layer (or (second (assoc :in-layer args)) nil)) (properties (cdr (assoc :default-properties args))) (cargs (remove-if #'(lambda (key) @@ -112,8 +118,9 @@ Attributes are the metadata used to display, validate, and otherwise manipulate (:default-initargs :properties (list ,@properties) ,@ (cdr (assoc :default-initargs args)))) - (defmethod find-attribute-class-for-type ((type (eql ',type))) - ',name)))) + ,(unless (not type-provided-p) + `(defmethod find-attribute-class-for-type ((type (eql ',type))) + ',name))))) (define-layered-class display-attribute (attribute) @@ -347,260 +354,6 @@ otherwise, (setf find-attribute)" :label ,label :slot-name ,slot-name))) - - -;;;; DEPRECIATED: Mewa presentations -;;;; this is legacy cruft. - - -(defcomponent mewa () - ((instance :accessor instance :initarg :instance) - (attributes - :initarg :attributes - :accessor attributes - :initform nil) - (attributes-getter - :accessor attributes-getter - :initform #'get-attributes - :initarg :attributes-getter) - (attribute-slot-map - :accessor attribute-slot-map - :initform nil) - (global-properties - :initarg :global-properties - :accessor global-properties - :initform nil) - (classes - :initarg :classes - :accessor classes - :initform nil) - (use-instance-class-p - :initarg :use-instance-class-p - :accessor use-instance-class-p - :initform t) - (initializedp :initform nil) - (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp) - (modifications :accessor modifications :initform nil))) - - -(defmethod attributes :around ((self mewa)) - (let ((a (call-next-method))) - (or a (funcall (attributes-getter self) self)))) - -(defgeneric get-attributes (mewa)) - -(defmethod get-attributes ((self mewa)) - (if (instance self) - (append (meta-model:list-slots (instance self)) - (meta-model:list-has-many (instance self))) - nil)) - -(defmethod find-instance-classes ((self mewa)) - (mapcar #'class-name - (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) - -(defun make-presentation-for-attribute-list-item - (occurence att-name plist parent-presentation &optional type) - (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 (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)))) - - ;(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) - (description.properties attribute))) - (list :size 30 :parent parent-presentation)))))) - -(defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) - "Returns a list of functions that, when called with an object presentation, -returns the ucw slot presentation that will be used to present this attribute -in that object presentation." - (loop for att in attribute-list - with funs = (list) - do (let ((att att)) (cond - ;;simple casee - ((symbolp att) - (push #'(lambda (p) - (make-presentation-for-attribute-list-item occurence att nil p)) - funs)) - ;;if the car is a keyword then this is an inline def - ;; drewc nov 12 2005: - ;; i never used this, and never told anybody about it. - ;; removing it. - #+ (or) ((and (listp x) (keywordp (car x))) - (let ((att (apply #'make-attribute x))) - (setf (cddr att) - (plist-union (cddr att) (global-properties self))) - att)) - - ;; if the plist has a :type - ((and (listp att) (getf (cdr att) :type)) - (let ((type (getf (cdr att) :type))) - (push #'(lambda (p) - (make-presentation-for-attribute-list-item - occurence (first att) - (cdr att) - p - type)) - funs))) - ;;finally if we are just overiding the props - ((and (listp att) (symbolp (car att))) - (push #'(lambda (p) - (make-presentation-for-attribute-list-item occurence (first att) (rest att) p)) - funs)))) - finally (return (nreverse funs)))) - - -(defun find-attribute-names (mewa) - (mapcar #'(lambda (x) - (if (listp x) - (first x) - x)) - (attributes mewa))) - -(defmethod find-applicable-attributes ((self mewa)) - (if (attributes self) - (find-applicable-attributes-using-attribute-list (instance self) (attributes self)) - (find-applicable-attributes-using-attribute-list (instance (get-attributes self))))) - - -(defmethod find-slot-presentations ((self mewa)) - (mapcar #'(lambda (a) (funcall a self)) - (find-applicable-attributes self))) - -(defmethod find-attribute-slot ((self mewa) (attribute symbol)) - (cdr (assoc attribute (attribute-slot-map self)))) - -(defmethod initialize-slots ((self mewa)) - (when (instance self) - (when (use-instance-class-p self) - (setf (classes self) - (append (find-instance-classes self) - (classes self)))) - (setf (attribute-slot-map self) (find-slot-presentations self)) - (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))) - - -(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)) - (d-a (when a (find-display-attribute (occurence a) (description.type (occurence a))))) - (i (apply #'make-instance - (if d-a - (find-old-type (description.type a)) - type) - (plist-union initargs (when a - (description.properties a)))))) - (setf (slot-value i 'instance) object) - (initialize-slots i) - (setf (slot-value i 'initializedp) t) - i)) - -(defmethod make-presentation ((list list) &key (type :listing) (initargs nil)) - (let ((args (append - `(:type ,type) - `(:initargs - (:instances ,list - ,@initargs))))) - - (apply #'make-presentation (car list) args))) - -(defmethod initialize-slots-place ((place ucw::place) (mewa mewa)) - (setf (slots mewa) (mapcar #'(lambda (x) - (prog1 x - (setf (component.place x) place))) - (slots mewa)))) - -(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa)) - (unless (slot-value to 'initializedp) - (initialize-slots to)) - (setf (slot-value to 'initializedp) t) - (initialize-slots-place (component.place from) to) - to) - - - -(defmacro call-presentation (object &rest args) - `(present-object ,object :presentation (make-presentation ,object ,@args))) - - -(defcomponent about-dialog (option-dialog) - ((body :initarg :body))) - -(defmethod render-on ((res response) (self about-dialog)) - (call-next-method) - (render-on res (slot-value self 'body))) - - -(defaction cancel-save-instance ((self mewa)) - (cond - ((meta-model::persistentp (instance self)) - (meta-model::update-instance-from-records (instance self)) - (answer self)) - (t (answer nil)))) - -(defaction save-instance ((self mewa)) - (meta-model:sync-instance (instance self)) - (setf (modifiedp self) nil) - (answer self)) - -(defmethod confirm-sync-instance ((self mewa)) - nil) - -(defaction ensure-instance-sync ((self mewa)) - (when (modifiedp self) - (if nil - (let ((message (format nil "Record has been modified, Do you wish to save the changes?"))) - (case (call 'about-dialog - :body (make-presentation (instance self) - :type :viewer) - :message message - :options '((:save . "Save changes to Database") - (:cancel . "Cancel all changes"))) - (:cancel - (cancel-save-instance self)) - (:save - (save-instance self)))) - (save-instance self)))) - -(defaction sync-and-answer ((self mewa)) - (ensure-instance-sync self) - (answer (instance self))) - -(defaction ok ((self mewa) &optional arg) - "Returns the component if it has not been modified. if it has been, prompt user to save or cancel" - ;(declare (ignore arg)) - (sync-and-answer self)) - -(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) - (let* ((old (prog1 - (presentation-slot-value slot instance) - (call-next-method))) - (new (presentation-slot-value slot instance))) - - (unless (equal new old ) - (let ((self (ucw::parent slot))) - (setf (modifiedp self) instance - (modifications self) (append (list new old value slot instance) (modifications self))))))) - - - - - - - ;; This software is Copyright (c) Drew Crampsie, 2004-2005. ;; You are granted the rights to distribute ;; and use this software as governed by the terms diff --git a/src/packages.lisp b/src/packages.lisp index 087b2f4..683edfe 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -53,6 +53,20 @@ :display-using-description :call-display + ;;;; Standard Layers + + :editor + :one-line + :as-string + :as-table + ;;;; "Lines", the newest creation. + :defline + :line-in + :line-out + + + :action + ;;;;a wrapper for calling make-presentation :call-view diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp index 58014f4..7e17d58 100644 --- a/src/relational-attributes.lisp +++ b/src/relational-attributes.lisp @@ -46,7 +46,7 @@ (dolist* (obj (find-all-foreign-objects object attribute)) (