From e1645f63189477f1b39a173a41fcbbfefb5e88a6 Mon Sep 17 00:00:00 2001 From: drewc Date: Sat, 6 May 2006 15:52:43 -0700 Subject: [PATCH] subclass UCW's form classes in the editor layer. darcs-hash:20060506225243-39164-1401ce0a2973516a1117c201772ef9b7443fbdf8.gz --- src/attributes/numbers.lisp | 5 ++ src/standard-attributes.lisp | 88 +++++++++++++++++++++++++++--------- src/standard-display.lisp | 46 +++++++++++-------- src/standard-wrappers.lisp | 30 ++++++++---- 4 files changed, 120 insertions(+), 49 deletions(-) diff --git a/src/attributes/numbers.lisp b/src/attributes/numbers.lisp index 6fb0460..a2d4b8f 100644 --- a/src/attributes/numbers.lisp +++ b/src/attributes/numbers.lisp @@ -9,6 +9,11 @@ () (:type-name integer)) +(defattribute integer-attribute (number-attribute integer-field) + () + (:in-layer editor) + (:type-name integer)) + (define-layered-method (setf attribute-value) ((value string) object (attribute integer-attribute)) (let ((*read-eval* nil)) diff --git a/src/standard-attributes.lisp b/src/standard-attributes.lisp index a34a1f6..53022aa 100644 --- a/src/standard-attributes.lisp +++ b/src/standard-attributes.lisp @@ -1,5 +1,6 @@ (in-package :lisp-on-lines) +;;;; A few layers related to attributes (deflayer omit-nil-attributes) (defdisplay :in-layer omit-nil-attributes @@ -7,17 +8,36 @@ (when (attribute-value object attribute) (call-next-method))) -(deflayer label-attributes) +(deflayer show-attribute-labels) -(defdisplay :in-layer label-attributes - :around ((attribute standard-attribute) object) +(defdisplay + :in-layer show-attribute-labels + :around ((attribute standard-attribute) object) + + (<:span + :class "lol-label" + (<:as-html (or (label attribute) (attribute.name attribute)) " ")) + (<:span + :class "lol-attribute" + (call-next-method))) + +(deflayer use-pretty-labels) + +(define-layered-method label + :in-layer use-pretty-labels + :around (standard-attribute) + (let ((label (call-next-method))) + (when label + (string-capitalize + (substitute #\Space #\- label))))) + +(defattribute display () + () + (:documentation "Apply the display function to this object")) - (<:span - :class "lol-label" - (<:as-html (or (label attribute) (attribute.name attribute)))) - (<:span - :class "lol-attribute" - (call-next-method))) +(defdisplay ((attribute display) object) + (apply #'display self (attribute-value object attribute) + (description.properties attribute))) ;;;; * Base Types @@ -27,23 +47,56 @@ (defdisplay ((base base-attribute) object) (<:as-html (attribute-value object base))) - -(defattribute base-attribute () +(defattribute base-attribute (ucw::string-field) () (:in-layer editor) (:default-properties :callback nil)) +(defmethod ucw:client-value ((self base-attribute)) + (attribute-value (object self) self)) + +(defmethod (setf ucw:client-value) (value (attribute base-attribute)) + (setf (attribute-value (object attribute) attribute) value)) + + +(defmethod render ((field base-attribute)) + "this can only be used within a display-using-description call in the editor context, + it is a hack to integrate lol with ucw's new form stuff" + (call-next-method)) + + #+ (or) +(LET ((value (attribute-value (object field) field))) + (<:as-html "asd" value) + (<:input + :NAME + (callback field) + :VALUE (escape-as-html value) + :TYPE + "text" + :ID + (DOM-ID FIELD) + :SIZE + (ucw::INPUT-SIZE FIELD))) + + + +(defdisplay + :in-layer editor ((string base-attribute) object) + (render string)) + + (defdisplay :in-layer editor :around ((string base-attribute) object) (dletf (((callback string) (ucw::make-new-callback #'(lambda (val) - (setf (attribute-value object string) val))))) + (setf (attribute-value object string) val)))) + ((object string) object)) (call-next-method))) ;;;; Strings -(defattribute string-attribute () +(defattribute string-attribute (base-attribute) () (:type-name string) (:default-properties @@ -51,15 +104,6 @@ :size nil :max-length nil)) -(defdisplay - :in-layer editor ((string base-attribute) object) - (<:input - :type "text" - :id (id string) - :name (callback string) - :value (or (attribute-value object string) ""))) - - (defdisplay :in-layer omit-nil-attributes :around ((attribute string-attribute) object) (when (< 0 (length (attribute-value object attribute))) diff --git a/src/standard-display.lisp b/src/standard-display.lisp index a5b0f0e..ba2846b 100644 --- a/src/standard-display.lisp +++ b/src/standard-display.lisp @@ -4,24 +4,24 @@ (deflayer viewer) (deflayer editor) +(define-layered-method label (anything) + nil) + (defdisplay :in-layer editor :around (description object) - "It is useful to remove the viewer layer when in the editing layer. + "It is useful to remove the viewer layer when in the editing layer. This allows us to dispatch to a subclasses editor." - (with-inactive-layers (viewer) - (call-next-method))) + (with-inactive-layers (viewer) + (call-next-method))) -(deflayer creator) +;;;; These layers affect the layout of the object (deflayer one-line) (deflayer as-table) - - - (deflayer as-string) (defdisplay :in-layer as-string (d o) - (with-inactive-layers (editor viewer creator one-line as-table label-attributes) + (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) (do-attributes (a d) (display-attribute a o) (<:as-is " ")))) @@ -46,12 +46,12 @@ This allows us to dispatch to a subclasses editor." (defcomponent standard-display-component () ((context :accessor context :initarg :context) - (object :accessor object :initarg :object) + (object :accessor object-of :initarg :object) (args :accessor args :initarg :args))) (defmethod render ((self standard-display-component)) - (apply #'display self (object self) (args self))) + (apply #'display self (object-of self) (args self))) ;;;; * Object displays. @@ -109,11 +109,11 @@ This allows us to dispatch to a subclasses editor." ;;;; ** One line (defdisplay - :in-layer one-line (description object) - "The one line presentation just displays the attributes with a #\Space between them" - (do-attributes (attribute description) - (display-attribute attribute object) - (<:as-html " "))) + :in-layer one-line (description object) + "The one line presentation just displays the attributes with a #\Space between them" + (do-attributes (attribute description) + (display-attribute attribute object) + (<:as-html " "))) ;;;; ** as-table @@ -125,11 +125,19 @@ This allows us to dispatch to a subclasses editor." (<:td (display-attribute a object)))))) ;;;; List Displays + +(deflayer list-display-layer) + +(define-layered-class description + :in-layer list-display-layer () + ((list-item :initarg :list-item :initform nil :special t :accessor list-item))) + (defdisplay (desc (list list)) - (<:ul - (dolist* (item list) - (<:li (display* item) - (<:as-html item))))) + (with-active-layers (list-display-layer) + + (<:ul + (dolist* (item list) + (<:li (apply #'display* item (list-item desc))))))) ;;;; Attributes (defdisplay diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp index e9c0b48..43151ca 100644 --- a/src/standard-wrappers.lisp +++ b/src/standard-wrappers.lisp @@ -40,23 +40,37 @@ (