(in-package :lisp-on-lines)
+
+;TODO: get rid of this.
+(defun attribute.name (attribute)
+ (attribute-name attribute))
+
+
;;;; A few layers related to attributes
(deflayer omit-nil-attributes)
(when (attribute-value object attribute)
(call-next-method)))
+;;;; Labels
(deflayer show-attribute-labels)
+(defattribute attribute-label (attribute)
+ ()
+ (:default-properties
+ :attribute nil))
+
+(defdisplay
+ ((label attribute-label) object)
+ (<:label
+ :class "lol-label"
+ (<:as-html (or (label (attribute label))
+ (attribute-name (attribute label)) " ")
+ " ")))
+
+(defvar *attribute-label-attribute*
+ (make-instance 'attribute-label))
+
(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)))
+ :around ((attribute standard-attribute) object)
+ (display-attribute *attribute-label-attribute* object :attribute attribute)
+ (call-next-method))
(deflayer use-pretty-labels)
(string-capitalize
(substitute #\Space #\- label)))))
-(defattribute display ()
- ()
+(deflayer inspect-attributes)
+
+(defdisplay :in-layer inspect-attributes
+ :around ((attribute standard-attribute) object)
+ (call-next-method)
+ (<ucw:a :action-body (ucw::call-inspector self attribute)
+ :title
+ (strcat "Inspect "
+ (attribute-name attribute) ":"
+ (description-type attribute) ":"
+ (type-of attribute))
+ (<:as-html "(i)")))
+
+;;;; Functional attributes
+(defattribute display-attribute ()
+ ((display-arguments
+ :accessor display-arguments
+ :initarg :display
+ :special t
+ :initform nil))
+ (:type-name display)
(:documentation "Apply the display function to this object"))
-(defdisplay ((attribute display) object)
+(defdisplay ((attribute display-attribute) object)
(apply #'display self (attribute-value object attribute)
- (description.properties attribute)))
+ (display-arguments attribute)))
-;;;; * Base Types
+(defattribute function-attribute ()
+ ((function :accessor function-of
+ :initarg :function
+ :initform #'funcall
+ :special t))
+ (:type-name function)
+ (:documentation ""))
-(defattribute base-attribute ()
- ())
+(defdisplay ((function function-attribute) object)
+ (funcall (function-of function)
+ (attribute-value object function)))
-(defdisplay ((base base-attribute) object)
- (<:as-html (attribute-value object base)))
-(defattribute base-attribute (ucw::string-field)
+;;;; Attribute Grouping
+(defattribute attribute-group ()
()
- (:in-layer editor)
(:default-properties
- :callback nil))
+ :group nil)
+ (:type-name group))
-(defmethod ucw:client-value ((self base-attribute))
- (attribute-value (object self) self))
+(defdisplay ((group attribute-group) object)
+ (apply #'display self object
+ :attributes (attributes group)
+ (group group)))
-(defmethod (setf ucw:client-value) (value (attribute base-attribute))
- (setf (attribute-value (object attribute) attribute) value))
+(defattribute select-attribute (display-attribute)
+ ()
+ (:default-properties
+ :test 'meta-model::generic-equal
+ :options-getter (constantly nil))
+ (:type-name select))
-(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))
+(defdisplay ((attribute select-attribute) object)
+ (<ucw:select
+ :accessor (attribute-value object attribute)
- #+ (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)))
+ :test (test attribute)
+ (dolist* (obj (funcall (options-getter attribute) object))
+ (<ucw:option
+ :value obj
+ (apply #'display* obj (display-arguments attribute))))))
+;;;; * Base Types
+(defattribute base-attribute ()
+ ()
+ (:default-properties
+ :default-value ""))
-(defdisplay
- :in-layer editor ((string base-attribute) object)
- (render string))
+(defdisplay ((base base-attribute) object)
+ (<:as-html (attribute-value object base)))
+(defattribute base-attribute ()
+ ()
+ (:in-layer editor)
+ (:default-properties
+ :callback nil
+ :default-value nil
+ :default-value-predicate #'null
+ :dom-id (js:gen-js-name-string :prefix "_ucw_")
+ :input-size nil))
+
+(define-layered-function display-value (attribute value)
+ (:method (attribute value)
+ (if (funcall (default-value-predicate attribute) value)
+ (default-value attribute)
+ value)))
+
+(defdisplay
+ :in-layer editor ((field base-attribute) object)
+ (LET ((value (attribute-value (object field) field)))
+ (<:input
+ :NAME
+ (callback field)
+ :VALUE (escape-as-html (strcat (display-value field value)))
+ :TYPE
+ "text"
+ :ID
+ (DOM-ID FIELD)
+ :SIZE
+ (INPUT-SIZE FIELD))))
(defdisplay
:in-layer editor :around ((string base-attribute) object)
- (dletf (((callback string) (ucw::make-new-callback
- #'(lambda (val)
- (setf (attribute-value object string) val))))
+ (dletf (((callback string)
+ (or (callback string)
+ (ucw::register-callback
+ #'(lambda (val)
+ (setf (attribute-value object string) val)))))
((object string) object))
(call-next-method)))
(:default-properties
:escape-html-p t
:size nil
- :max-length nil))
+ :max-length nil
+ :default-value ""))
+
+
+#|
(defdisplay :in-layer omit-nil-attributes
:around ((attribute string-attribute) object)
;;;; editor
-(defattribute string-attribute (base-attribute)
+#+nil (defattribute string-attribute (base-attribute)
()
(:in-layer editor)
(:default-properties
(defdisplay :in-layer editor ((string text-attribute) object)
(<:textarea
- :id (id string)
+ :id (dom-id string)
:name (callback string)
(or (attribute-value object string) "")))
(<:div
:class "lol-image-thumbnails"
- (<:as-html "imagie")))
+ (<:as-html "imagie"))) |#
HCoop / clinton / lisp-on-lines.git / blobdiff