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

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index b0cbff9..b180396 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 #<UNBOUND>
+Number #<UNBOUND>"))
+
+  (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 (file)
--- 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 (file)
--- 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 (file)
--- 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)
+  (<lol:input :type "text"
+             :reader (attribute-value attribute)
+             :writer (make-attribute-value-writer attribute)))
+
+(defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
+  (<lol:input :type "password"
+             :reader (attribute-value attribute)
+             :writer (make-attribute-value-writer attribute)))
+
+
+(define-layered-method display-attribute-editor 
+   :in-layer #.(defining-description 'html-description) (attribute)
+   (display-html-attribute-editor attribute (attribute-editor attribute)))
+                                            
 
 (define-layered-method display-html-attribute-value 
   :in-layer #.(defining-description 'editable) (object attribute)
 
     (<:span 
        :class "lol-attribute-value"
-    (if (attribute-editp object attribute)     
-    (<lol:input :reader (attribute-value attribute)
-               :writer (let ((obj (described-object (attribute-description attribute))))
-                         (lambda (val)
-                           (dletf (((described-object attribute) obj))
-                             (setf (attribute-value attribute) val)))))
-    (call-next-method))
-))             
+    (if (attribute-editp attribute)    
+       (display-attribute-editor attribute)
+    
+       (call-next-method))))           
 
 (define-layered-function display-html-description (description display object &optional next-method)
   (:method (description display object &optional (next-method #'display-using-description))