X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/dee565d0d3252060ce31e8de57708ff9edb054d5..60a24293adb9a76f8530175efb05e24a7f953e42:/src/standard-display.lisp diff --git a/src/standard-display.lisp b/src/standard-display.lisp index c756096..9bcf3ff 100644 --- a/src/standard-display.lisp +++ b/src/standard-display.lisp @@ -11,6 +11,8 @@ (deflayer wrap-form) +(deflayer as-table) + (define-attributes (contextl-default) (:viewer viewer) (:editor editor) @@ -23,53 +25,61 @@ (apply #'display ,component thing args))) ,@body))) -(defmacro call-display (object &rest args) - `(call-component self (make-instance 'standard-display-component - :display #'(lambda (component) - (with-component (component) - (<:as-html ,object) - (display ,object ,@args)))))) -;;;;; Macros +(define-layered-function find-display-type (object)) -(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))))) - (flet ((display-attribute* (component object) - (display-using-description - ,var - component - object - (rest ,att)))) - (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var) - ,@body)))))) +(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"))))) + (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))) - (declare (ignorable #',get #',set)) + (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) @@ -77,23 +87,25 @@ (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 - ,(if object (if (listp object) object (list object object)) 'object) properties) - (declare (ignorable display-attribute)) + ,class-spec properties) + (with-plist ((plist-union properties (find-plist ,(car description)))) ,(if (not description-supplied-p) - `(flet ((display-attribute (attribute) - (let ((a (ensure-list attribute))) - (display-using-description (find-attribute ,(car description) (car a)) ,component ,(car (ensure-list object)) (cdr a))))) + `(flet ((attributes () + (or (getp :attributes) + (list-slots ,(car (ensure-list class-spec)))))) + (declare (ignorable #'attributes)) ,@body) - `(progn ,@body))))) + `(progn ,@body)))) ) + ) (define-layered-function display (component object &rest args) @@ -102,10 +114,8 @@ default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method.")) - - (define-layered-method display - ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys) + ((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)))) @@ -117,18 +127,12 @@ layers #'display-using-description occurence component object (plist-union args plist)))) + (define-layered-method display - ((component t) (object symbol) &rest args &key (layers '(+ viewer)) &allow-other-keys) + ((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-method display ((component t) (list list) &rest args) - "The Default Display* for LISTS" - (<:ul - (dolist* (item list) - (<:li (apply #'display component item args))))) + layers + #'display-using-description t component object args)) (define-layered-function display-using-description (description component object properties) @@ -140,58 +144,80 @@ (declare (ignore component properties description)) (<:as-html object)) +;;;; * Object Presentations (define-layered-method display-using-description - ((occurence standard-occurence) component object properties) + ((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)))) - (warn "trying to render ~A in ~A" attribute object) (with-plist ((plist-union (rest att) (find-plist attribute))) (<:p :class "attribute" - (<:span :class "label" (<:as-html (getp :label) " ")) + (and (getp :show-labels-p) (<:span :class "label" (<:as-html (or (getp :label) "") " "))) (display-using-description attribute component object (rest att)))))))) -(define-layered-method display-using-description - :in-layer one-line ((occurence standard-occurence) component object properties) - (with-plist (properties occurence) - (do-attributes (attribute occurence (or (occurence-getp :attributes) - (list-slots object))) - (display-attribute* component object) (<:as-html " ")))) -(define-layered-method display-using-description ((attribute standard-attribute) component object properties) - (let ((p (lol:make-view object :type :viewer)) - (name (attribute.name attribute))) - (when name (present-slot-view p name)))) +;;;; ** 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" + "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)) - (