From f4efa7fff2efa6a3144fc664683137df92c42f91 Mon Sep 17 00:00:00 2001 From: drewc Date: Mon, 21 Apr 2008 15:13:03 -0700 Subject: [PATCH] Expanded support for Configurable editing. Added an :input initarg to the editable standard-attribute. This option recieves a keyword list that is applied via make-instance to create and attribute-editor-object. darcs-hash:20080421221303-39164-ffb80e27ff26d67517e0c1075df347ef24f932bc.gz --- lisp-on-lines.asd | 7 +- src/packages.lisp | 9 +- src/rofl.lisp | 28 ++++-- src/standard-descriptions/clos.lisp | 8 ++ src/standard-descriptions/edit-test.lisp | 24 +++++ src/standard-descriptions/edit.lisp | 109 +++++++++++++++++------ src/standard-descriptions/t.lisp | 19 ++-- src/ucw/html-description.lisp | 35 ++++++-- 8 files changed, 186 insertions(+), 53 deletions(-) create mode 100644 src/standard-descriptions/edit-test.lisp diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index b0cbff9..b180396 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -66,9 +66,9 @@ OTHER DEALINGS IN THE SOFTWARE." :serial t)) :serial t - :depends-on (:contextl :arnesi :alexandria + :depends-on (:contextl :arnesi :alexandria :parse-number ;;for rofl: - :postmodern :simple-date)) + :simple-date :postmodern)) @@ -80,6 +80,9 @@ OTHER DEALINGS IN THE SOFTWARE." (:file "attribute-test") (:file "display-test") (:file "rofl-test") + (:module :standard-descriptions + :components ((:file "edit-test")) + :serial t) (:module :ucw :components ((:file "ucw-test")) :serial t)) diff --git a/src/packages.lisp b/src/packages.lisp index 21d2151..44a6977 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -24,6 +24,7 @@ #:define-description #:described-object #:described-class + #:described-standard-class #:with-active-descriptions #:with-inactive-descriptions @@ -41,6 +42,12 @@ #:attribute-label #:attribute-function #:attribute-value - #:active-attributes)) + #:active-attributes + + ;; Standard Library + #:editable + #:string-attribute-editor + #:number-attribute-editor + #:password-attribute-editor)) diff --git a/src/rofl.lisp b/src/rofl.lisp index 3d73725..9b2e6dc 100644 --- a/src/rofl.lisp +++ b/src/rofl.lisp @@ -197,14 +197,30 @@ inheritance and does not create any tables for it.")) (%select-objects type #'select query)) (defun select-only-n-objects (n type &rest query) - (let ((results (%query `(:limit ,(cons :select - (intern (format nil "*")) - (if (string-equal (first query) :from) - query - (append `(:from ,type) query))) ,n)))) + (let ((fields (if (eq :fields (car query)) + (loop + :for cons :on (cdr query) + :if (not (keywordp (car cons))) + :collect (car cons) into fields + :else :do + (setf query cons) + (return (nreverse (print fields))) + :finally + (setf query cons) + (return (nreverse (print fields)))) + + (list (intern "*"))))) + (let ((results + (%query + (print `(:limit (:select + ,@fields + ,@(if (string-equal (first query) :from) + (print query) + (append `(:from ,type) query))) + ,n))))) (if (eql 1 n) (make-object-from-plist type (first results)) - (mapcar (curry 'make-object-from-plist type) results)))) + (mapcar (curry 'make-object-from-plist type) results))))) (defun make-object-from-plist (type plist) (let* ((class (find-class type)) diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index dc056a1..f9e661c 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -76,10 +76,18 @@ (finalize-inheritance class) (ensure-description-for-class class)) +(defclass described-standard-class (standard-class described-class) ()) + +(defmethod validate-superclass + ((class described-standard-class) + (superclass standard-class)) + t) (define-layered-method description-of ((object standard-object)) (or (ignore-errors (find-description (class-name (class-of object)))) (find-description 'standard-object))) + + diff --git a/src/standard-descriptions/edit-test.lisp b/src/standard-descriptions/edit-test.lisp new file mode 100644 index 0000000..a62bda6 --- /dev/null +++ b/src/standard-descriptions/edit-test.lisp @@ -0,0 +1,24 @@ +(in-package :lol-test) + +(deftest test-edit-simple () + (eval `(defclass edit-test () + (string number) + (:metaclass described-standard-class))) + (eval `(define-description edit-test (description-for-edit-test) + ((string :input (:type string)) + (number :input (:type number))))) + + (is (string= (display nil (make-instance 'lol-test::edit-test)) + "String # +Number #")) + + (progn (let ((i (make-instance 'lol-test::edit-test))) + (with-input-from-string (*standard-input* +"drew +1 +") + (with-active-descriptions (editable) + (display t i)) + (is (equal (display nil i) +"String drew +Number 1")))))) \ No newline at end of file diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp index 0033502..aa71065 100644 --- a/src/standard-descriptions/edit.lisp +++ b/src/standard-descriptions/edit.lisp @@ -5,6 +5,71 @@ () (:mixinp t)) +(define-layered-class standard-attribute + :in-layer #.(defining-description 'editable) + () + ((edit-attribute-p + :initform :inherit + :layered-accessor attribute-editp + :initarg :editp + :layered t) + (setter + :initarg :setter + :layered t + :accessor attribute-setter + :initform nil) + (attribute-editor + :initarg :input + :layered t + :accessor attribute-editor + :initform nil + :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))))) + + +(defclass attribute-editor () + ((type :initarg :type + :initform 'string) + (parser :initarg :parse-using + :initform 'identity + :accessor attribute-editor-parsing-function) + (prompt :initarg :prompt + :initform nil))) + +(defclass string-attribute-editor (attribute-editor) ()) +(defclass text-attribute-editor (string-attribute-editor) ()) +(defclass password-attribute-editor (string-attribute-editor) ()) + +(defclass number-attribute-editor (attribute-editor) () + (:default-initargs + :parse-using 'parse-number:PARSE-NUMBER + :type 'number)) + +(defun parse-attribute-value (attribute value) + (funcall (attribute-editor-parsing-function + (attribute-editor attribute)) + value)) + +(define-layered-function display-attribute-editor (attribute) + (:method (attribute) + (setf (attribute-value attribute) + (funcall (attribute-editor-parsing-function + (attribute-editor attribute)) + (read-line))))) + (define-description T () ((editp :label "Edit by Default?" :value nil @@ -22,42 +87,30 @@ (funcall setter value object) (error "No setter in ~A for ~A" attribute object)))) -(define-layered-class standard-attribute - :in-layer #.(defining-description 'editable) - () - ((edit-attribute-p - :initform :inherit - :accessor %attribute-editp - :initarg :editp - :layered t) - (setter - :initarg :setter - :layered t - :accessor attribute-setter - :initform nil))) -(define-layered-function attribute-editp (object attribute) - (:method (object attribute) nil)) +(define-layered-function attribute-editp (attribute) + (:method (attribute) nil)) (define-layered-method attribute-editp :in-layer #.(defining-description 'editable) - (object (attribute standard-attribute)) - - (if (eq :inherit (%attribute-editp attribute)) - (attribute-value (find-attribute - (attribute-description attribute) - 'editp)) - (%attribute-editp attribute))) + ((attribute standard-attribute)) + (let ((edit? (call-next-method))) + (if (eq :inherit edit?) + (attribute-value (find-attribute + (attribute-description attribute) + 'editp)) + edit?))) -(define-layered-method display-using-description +(define-layered-method display-attribute-value :in-layer #.(defining-description 'editable) - ((attribute standard-attribute) display object &rest args) - - (declare (ignore args)) - (if (attribute-editp object attribute) - (format *display* "This is where we'd edit") + ((attribute standard-attribute)) + (if (attribute-editp attribute) + (display-attribute-editor attribute) (call-next-method))) + + + \ No newline at end of file diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp index e5c6676..fd8a712 100644 --- a/src/standard-descriptions/t.lisp +++ b/src/standard-descriptions/t.lisp @@ -20,8 +20,11 @@ :value nil :activep nil :keyword :deactivate) - (label-formatter :value (curry #'format nil "~A ")) - (value-formatter :value (curry #'format nil "~A")))) + (label-formatter :value (lambda (label) + (generic-format *display* "~A " label)) + :activep nil) + (value-formatter :value (curry #'format nil "~A") + :activep nil))) (define-layered-method description-of (any-lisp-object) (find-description 't)) @@ -32,8 +35,8 @@ (define-layered-function display-attribute-label (attribute) (:method (attribute) - (princ (funcall (attribute-label-formatter attribute) (attribute-label attribute)) - *display*))) + (funcall (attribute-label-formatter attribute) (attribute-label attribute)))) + (define-layered-function display-attribute-value (attribute) @@ -62,16 +65,16 @@ (define-display ((description t)) (let ((attributes (attributes description))) (display-attribute (first attributes)) - (dolist (attribute (rest attributes)) + (dolist (attribute (rest attributes) (values)) (generic-format *display* (attribute-value (find-attribute description 'attribute-delimiter))) (display-attribute attribute)))) -(define-display :around ((description t) (display null)) - (with-output-to-string (*display*) - (print (call-next-method) *display*))) +(define-display :around ((description t) (display null) object) + (with-output-to-string (*standard-output*) + (call-next-layered-method description t object))) diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp index f05d010..0a8c205 100644 --- a/src/ucw/html-description.lisp +++ b/src/ucw/html-description.lisp @@ -87,20 +87,39 @@ (display-html-attribute object attribute)) +(defun make-attribute-value-writer (attribute) + (let ((obj (described-object (attribute-description attribute)))) + (lambda (val) + (dletf (((described-object attribute) obj)) + (setf (attribute-value attribute) + (parse-attribute-value attribute val)))))) + + +(defmethod display-html-attribute-editor (attribute editor) + (