(find-attribute description 'active-attributes))
(attributes (when active-attributes
(ignore-errors (attribute-value active-attributes)))))
- (if attributes
- (mapcar (lambda (spec)
- (find-attribute
- description
- (if (listp spec)
- (car spec)
- spec)))
- attributes)
- (remove-if-not
- (lambda (attribute)
- (and (attribute-active-p attribute)
- (some #'layer-active-p
- (mapcar #'find-layer
- (slot-definition-layers
- (attribute-effective-attribute-definition attribute))))))
+ (remove-if-not
+ (lambda (attribute)
+ (and attribute
+ (attribute-active-p attribute)
+ (some #'layer-active-p
+ (mapcar #'find-layer
+ (slot-definition-layers
+ (attribute-effective-attribute-definition attribute))))))
+ (if attributes
+ (mapcar (lambda (spec)
+ (find-attribute
+ description
+ (if (listp spec)
+ (car spec)
+ spec)))
+ attributes)
(description-attributes description))))))
#:insert-into
#:select-objects
#:select-only-n-objects
+ #:insert-object
;; Descriptions
#:find-description
#:with-active-descriptions
#:with-inactive-descriptions
+
;; Displays
#:define-display
#:display
#:find-attribute
#:attribute
#:attributes
+ #:attribute-object
#:attribute-label
+ #:label
#:attribute-function
#:attribute-value
+ #:display-attribute-value
#:active-attributes
-
+ #:attribute-delimiter
+ #:standard-attribute
;; Standard Library
+
+ ;; editing
#:editable
+ #:attribute-editor
#:string-attribute-editor
#:number-attribute-editor
- #:password-attribute-editor))
+ #:password-attribute-editor
+ #:password
+
+ ;; html
+ #:display-html-attribute-editor
+ #:make-attribute-value-writer))
;;;; now the rofl code itself
+
+(defvar *row-reader* 'symbol-plist-row-reader)
+
(defun %query (query)
(cl-postgres:exec-query *database* (sql-compile query) 'symbol-plist-row-reader))
(slot-value object (attribute-slot-name attribute))
+unbound-slot+))
-(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
- (let ((desc-class
- (ensure-class (defining-description name)
- :direct-superclasses (list (class-of (find-description 'standard-object)))
- :direct-slots (loop :for slot in (class-slots class)
- :collect `(:name ,(slot-definition-name slot)
- :attribute-class slot-definition-attribute
- :slot-name ,(slot-definition-name slot)
- :label ,(format nil
- "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))
- :into slots
+(defun attribute-slot-makunbound (attribute)
+ (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
+
+(defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
+ direct-superclasses direct-slot-specs)
+
+ (let* ((super-descriptions
+ (mapcar #'class-of
+ (delete nil (mapcar (rcurry #'find-description nil)
+ (mapcar #'class-name direct-superclasses)))))
+ (desc-class
+ (ensure-class (defining-description name)
+ :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
+ :direct-slots
+ (loop
+ :for slot in (class-slots class)
+ :collect
+ (let ((direct-spec
+ (find (slot-definition-name slot)
+ direct-slot-specs
+ :key (rcurry 'getf :name))))
+ (if direct-spec
+ (append (alexandria:remove-from-plist direct-spec
+ :initfunction
+ :initform
+ :initargs
+ :readers
+ :writers)
+ (unless
+ (getf direct-spec :attribute-class)
+ (list :attribute-class 'slot-definition-attribute))
+ (unless
+ (getf direct-spec :label)
+ (list :label (format nil
+ "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
+ (list :slot-name (slot-definition-name slot)))
+ `(:name ,(slot-definition-name slot)
+ :attribute-class slot-definition-attribute
+ :slot-name ,(slot-definition-name slot)
+ :label ,(format nil
+ "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
+ :into slots
:collect (slot-definition-name slot) :into names
:finally (return (cons `(:name active-attributes
- :value ',names)
+ :value ',(or attributes names))
slots)))
- :metaclass 'standard-description-class)))
-
+ :metaclass 'standard-description-class)))
(unless (ignore-errors (find-description (class-name class)))
(ensure-class (defining-description (class-name class))
:direct-superclasses (list desc-class)
- :metaclass 'standard-description-class))
- (find-description name)))
+ :metaclass 'standard-description-class))
+ (find-description name)))
(defclass described-class ()
+ ((direct-slot-specs :accessor class-direct-slot-specs)
+ (attributes :initarg :attributes :initform nil)))
+
+(defmethod ensure-class-using-class :around ((class described-class) name &rest args)
+
+ (call-next-method))
+
+(defmethod direct-slot-definition-class ((class described-class) &rest initargs)
+ (let ((slot-class (call-next-method)))
+ (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
+
+(defclass described-class-direct-slot-definition ()
())
+(defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
+ (call-next-method))
+
(defmethod validate-superclass
((class described-class)
(superclass standard-class))
t)
-(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
+(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
(declare (dynamic-extent initargs))
(finalize-inheritance class)
- (ensure-description-for-class class))
-
+ (ensure-description-for-class class :direct-slot-specs direct-slots
+ :direct-superclasses direct-superclasses
+ :attributes (slot-value class 'attributes)))
-(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
(declare (dynamic-extent initargs))
(finalize-inheritance class)
- (ensure-description-for-class class))
+ (ensure-description-for-class class :direct-slot-specs direct-slots
+ :direct-superclasses direct-superclasses
+ :attributes (slot-value class 'attributes)))
-(defclass described-standard-class (standard-class described-class) ())
+(defclass described-standard-class (described-class standard-class ) ())
(defmethod validate-superclass
((class described-standard-class)
(find-description 'standard-object)))
-
-
-
(in-package :lisp-on-lines)
-
(define-description editable ()
()
(:mixinp t))
:accessor attribute-setter
:initform nil)
(attribute-editor
- :initarg :input
+ :initarg :editor
:layered t
:accessor attribute-editor
- :initform nil
+ :initform (make-instance 'attribute-editor)
:documentation "This ones a bit odd")))
-(defmethod attribute-editor :around (attribute)
- (flet ((find-editor-class (spec)
- (let ((class (getf spec :class))
- (type (getf spec :type)))
- (or class (when (and type (symbolp type))
- (intern (format nil "~A-~A" type 'attribute-editor)))
- 'string-attribute-editor))))
- (let ((editor? (call-next-method)))
- (if (listp editor?)
- (setf (attribute-editor attribute)
- (apply #'make-instance (find-editor-class editor?)
- editor?))
- (call-next-method)))))
-
+(defmethod shared-initialize :after ((object standard-attribute)
+ slots &rest args &key input &allow-other-keys)
+
+ (when input
+ (setf (attribute-editor object)
+ (apply #'make-instance (find-editor-class input)
+ input))))
+
+
+(defun find-editor-class (spec)
+ (let ((class (getf spec :class))
+ (type (getf spec :type)))
+ (or class (when
+ (and type (symbolp type))
+ (let ((name (format nil "~A-~A" type 'attribute-editor)))
+ (or (find-class (intern name (symbol-package type)) nil)
+ (find-class (intern name) nil)
+ 'string-attribute-editor))))))
(defclass attribute-editor ()
((type :initarg :type
- :initform 'string)
+ :initform 'string
+ :accessor attribute-editor-type)
(parser :initarg :parse-using
:initform 'identity
:accessor attribute-editor-parsing-function)
(prompt :initarg :prompt
- :initform nil)))
+ :initform nil)
+ (unbound-value
+ :initarg :unbound-value
+ :initform "")))
+
+
(defclass string-attribute-editor (attribute-editor) ())
(defclass text-attribute-editor (string-attribute-editor) ())
+
+(deftype password () 'string)
+
(defclass password-attribute-editor (string-attribute-editor) ())
(defclass number-attribute-editor (attribute-editor) ()
(define-layered-method attribute-editp
:in-layer #.(defining-description 'editable)
((attribute standard-attribute))
+ (let ((value (attribute-value attribute)))
+ (unless (or (unbound-slot-value-p value)
+ (typep value
+ (attribute-editor-type
+ (attribute-editor attribute))))
+ (return-from attribute-editp nil)))
(let ((edit? (call-next-method)))
(if (eq :inherit edit?)
(attribute-value (find-attribute
(in-package :lisp-on-lines)
-(define-description cons ()
+
+(define-layered-class list-attribute (standard-attribute)
+ ((item-args :initform nil :initarg :item :layered t :special t)))
+
+(define-layered-method display-attribute-value
+ ((attribute list-attribute))
+ (arnesi:dolist* (item (attribute-value attribute))
+ (apply #'display *display* item (slot-value attribute 'item-args))))
+
+(define-description list ()
+ ((list :attribute-class list-attribute
+ :function #'identity
+ :attributes nil)))
+
+(define-description cons (list)
((car :label "First" :function #'car)
- (cdr :label "Rest" :function #'cdr)))
+ (cdr :label "Rest" :function #'cdr)
+ ))
(define-description cons ()
((editp :value t :editp nil)
(cdr :setter #'rplacd))
(:in-description editable))
+(define-description cons ()
+ ((active-attributes :value '(list)))
+ (:in-description inline))
+
(define-layered-method description-of ((c cons))
(find-description 'cons))
(:method (attribute)
(display-using-description attribute *display* (attribute-object attribute))))
+
(define-layered-function display-attribute-label (attribute)
(:method (attribute)
(funcall (attribute-label-formatter attribute) (attribute-label attribute))))
+
(define-layered-function display-attribute-value (attribute)
(:method (attribute)
(flet ((disp (val &rest args)
args)))
(let ((val (attribute-value attribute)))
- (if (eql val (attribute-object attribute))
+ (if (and (not (slot-boundp attribute 'active-attributes))
+ (eql val (attribute-object attribute)))
(generic-format *display* (funcall (attribute-value-formatter attribute) val))
(with-active-descriptions (inline)
- (if (slot-boundp attribute 'active-attributes)
- (disp val :attributes (slot-value attribute 'active-attributes))
- (disp val))))))))
+ (cond ((slot-value attribute 'value-formatter)
+ (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
+ ((slot-boundp attribute 'active-attributes)
+ (disp val :attributes (slot-value attribute 'active-attributes)))
+ (t
+ (disp val)))))))))
(define-layered-method display-using-description
((attribute standard-attribute) display object &rest args)
(display-attribute-label attribute))
(display-attribute-value attribute))
+(define-layered-method display-attribute :around
+ ((attribute standard-attribute))
+ (funcall-with-layer-context
+ (modify-layer-context (current-layer-context)
+ :activate (attribute-active-descriptions attribute)
+ :deactivate (attribute-inactive-descriptions attribute))
+ (lambda ()
+ (call-next-method))))
+
+(define-layered-method display-attribute :before
+ ((attribute standard-attribute))
+)
+
(define-display ((description t))
(let ((attributes (attributes description)))
(display-attribute (first attributes))
(define-layered-class html-attribute ()
((css-class :accessor attribute-css-class
:initform "lol-attribute")
- (dom-id :accessor attribute-dom-id :initform nil)))
+ (dom-id :accessor attribute-dom-id :initform nil)
+ (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
(define-layered-class standard-attribute
:in-layer #.(defining-description 'html-description)
(define-layered-function display-html-attribute-label (object attribute)
(:method (object attribute)
+
(let ((label (attribute-label attribute)))
- (<:label
+ (when (or label (attribute-display-empty-label-p attribute))
+ (<:td (<:label
:class "lol-attribute-label"
(when label
(<:as-html
(with-output-to-string (*display*)
- (display-attribute-label attribute)))))))
+ (display-attribute-label attribute)))))))))
(:method
:in-layer #.(defining-description 'inline)
(object attribute)
(let ((label (attribute-label attribute)))
(when label
- (<:as-html
+ (<:as-html
(with-output-to-string (*display*)
(display-attribute-label attribute)))))))
(define-layered-function display-html-attribute-value (object attribute)
(:method (object attribute)
- (<:span
+ (<:td
:class "lol-attribute-value"
(<:as-html
(display-attribute-value attribute))))
(define-layered-function display-html-attribute (object attribute)
(:method (object attribute)
- (<:div
+ (<:tr
:class (attribute-css-class attribute)
(when (attribute-dom-id attribute)
:id (attribute-dom-id attribute))
(display-html-attribute object attribute))
+(defun capture-description (attribute function)
+ (let ((obj (described-object (attribute-description attribute))))
+ (lambda (&rest args)
+ (dletf (((described-object attribute) obj))
+ (apply function args)))))
+
(defun make-attribute-value-writer (attribute)
- (let ((obj (described-object (attribute-description attribute))))
+ (let ((obj (described-object (attribute-description attribute)))
+ (value (attribute-value attribute)))
(lambda (val)
(dletf (((described-object attribute) obj))
- (setf (attribute-value attribute)
- (parse-attribute-value attribute val))))))
+ (with-active-descriptions (editable)
+ (unless (and (unbound-slot-value-p value)
+ (equal "" val))
+ (setf (attribute-value attribute)
+ (parse-attribute-value attribute val))))))))
+
+(defmethod html-attribute-value (attribute)
+ (let ((val (attribute-value attribute)))
+ (if (unbound-slot-value-p val)
+ ""
+ val)))
(defmethod display-html-attribute-editor (attribute editor)
(<lol:input :type "text"
- :reader (attribute-value attribute)
+ :reader (html-attribute-value attribute)
:writer (make-attribute-value-writer attribute)))
+(defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
+ (call-next-method))
+
(defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
(<lol:input :type "password"
- :reader (attribute-value attribute)
+ :reader (html-attribute-value attribute)
:writer (make-attribute-value-writer attribute)))
(define-layered-method display-html-attribute-value
:in-layer #.(defining-description 'editable) (object attribute)
- (<:span
+ (<:td
:class "lol-attribute-value"
(if (attribute-editp attribute)
(display-attribute-editor attribute)
-
(call-next-method))))
(define-layered-function display-html-description (description display object &optional next-method)
(<:style
(<:as-html "
+
+
div.lol-description .lol-attribute-label,
div.lol-description .lol-attribute-value {
display: block;
width: 69%;
float: left;
margin-bottom: 1em;
+border:1px solid black;
}
div.lol-description
.lol-attribute-label {
text-align: right;
width: 24%;
- padding-right: 20px;
+ padding-right: 1em;
}
+span.lol-attribute-value .lol-attribute-value (
+ border: 1px solid red;}
+
div.lol-description
br {
clear: left;
-}"))
+}
+
+.clear {clear:left}"
+
+))
(with-attributes (css-class dom-id) description
- (<:div
+ (<:table
:class (list (attribute-value css-class) "lol-description" "t")
:id (attribute-value dom-id)
- (funcall next-method)))))
+ (funcall next-method)
+ (<:br :class "clear")))))
(define-layered-method display-html-description
(display-html-description description display object (lambda ()
(call-next-method))))
+(define-layered-method display-html-attribute-value
+ (object (attribute list-attribute))
+ (<:ul
+ (arnesi:dolist* (item (attribute-value attribute))
+ (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))
`(<:input :value ,reader
:name (register-callback ,writer)
,@others)))
+
+
+(deftag-macro <lol::%select (&attribute writer accessor
+ (test '#'eql)
+ (key '#'identity)
+ name (id (js:gen-js-name-string :prefix "sel"))
+ &allow-other-attributes others
+ &body body)
+ "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
+ "You need to supply either an accessor or a writer to <ucw:select"
+ (with-unique-names (id-value v val values)
+ (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
+ `(let ((%current-select-value ,accessor)
+ (%current-select-test ,test)
+ (%current-select-key ,key)
+ (%select-table nil)
+ (,id-value ,id))
+ (declare (ignorable %current-select-value %current-select-test %current-select-key
+ %select-table ))
+ (<:select :name (register-callback
+ (flet ((get-associated-value (v)
+ (let ((v (assoc v %select-table :test #'string=)))
+ (if v
+ (cdr v)
+ (error "Unknown option value: ~S." v)))))
+ (lambda (,v) (funcall ,writer (get-associated-value ,v))))
+ :id ,name)
+ :id ,id-value
+ ,@others
+ ,@body)))))
+
+(deftag-macro <lol::%select-action (&attribute writer accessor
+ (test '#'eql)
+ (key '#'identity)
+ name (id (js:gen-js-name-string :prefix "sel"))
+ &allow-other-attributes others
+ &body body)
+ "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
+ "You need to supply either an accessor or a writer to <ucw:select"
+ (with-unique-names (id-value v val values)
+ (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
+ `(let ((%current-select-value ,accessor)
+ (%current-select-test ,test)
+ (%current-select-key ,key)
+ (%select-table nil)
+ (,id-value ,id))
+ (declare (ignorable %current-select-value %current-select-test %current-select-key
+ %select-table ))
+ (<:select :name (register-callback
+ (flet ((get-associated-value (v)
+ (let ((v (assoc v %select-table :test #'string=)))
+ (if v
+ (cdr v)
+ (error "Unknown option value: ~S." v)))))
+ (lambda (,v) (funcall ,writer (get-associated-value ,v))))
+ :id ,name)
+ :id ,id-value
+ ,@others
+ ,@body)))))
+
+(deftag-macro <lol:select (&allow-other-attributes others
+ &body body)
+ `(<lol::%select ,@others ,@body))
+
+(deftag-macro <lol::%option (&attribute value &allow-other-attributes others &body body)
+ (with-unique-names (value-id)
+ (rebinding (value)
+ `(let ((,value-id (random-string 10)))
+ (push (cons ,value-id ,value) %select-table)
+ (<:option :value ,value-id
+ ;;NB: we are applying key to both the option value being rendered,
+ ;; as well as the selected value(s).
+ ;;That was how the code worked previously, I don't know if it is desirable.
+ ;;I think the alternative would be to apply the key to ",value" that is
+ ;; the option being rendered, and remove the :key argument from find.
+
+ ;;The logical operation we are trying to accomplish is
+ ;;(mapcar #'add-selected-attribute
+ ;; (find-all %current-select-value(s)
+ ;; (list-of-collected-<lol::%option-calls)
+ ;; :key %current-select-key))
+ :selected (when (find
+ (funcall %current-select-key ,value) ;key applied to an option
+ (if nil ;%multiple
+ %current-select-value
+ (list %current-select-value))
+ :test %current-select-test
+ :key %current-select-key)
+ T)
+ ,@others ,@body)))))
+
+(deftag-macro <lol:option (&allow-other-attributes others &body body)
+ "Replacement for the standard OPTION tag, must be used with
+ <LOL:SELECT tag. Unlike \"regular\" OPTION tags the :value
+ attribute can be any lisp object (printable or not)."
+ `(<lol::%option ,@others ,@body))
(defpackage lisp-on-lines-ucw
(:documentation "An LoL Layer over ucw.basic")
(:nicknames #:lol-ucw)
- (:use #:lisp-on-lines #:ucw :common-lisp :arnesi :yaclml :puri)
+ (:use #:lisp-on-lines #:ucw :common-lisp :arnesi :yaclml)
(:shadow
#:standard-window-component
#:make-action
(apply #'make-instance name args)))
(defun/cc answer (&optional val)
- (answer-component *source-component*
- val))
+ (let ((child *source-component*))
+ (setf *source-component* (ucw::component.calling-component child))
+ (answer-component child val)))
-(defclass described-component-class (standard-component-class described-class)
+(defclass described-component-class (described-class standard-component-class )
())
(defmacro defaction (&rest args-and-body)
(return action-id))))
(call-next-method)))
+
+
+
+
(defcomponent standard-window-component
- (ucw:basic-window-component)
+ (ucw::basic-window-component)
((body
:initform nil
:accessor window-body