Commit 9a7e59ff authored by hayeah via gmail com's avatar hayeah via gmail com

Preliminary work on submit forms

darcs-hash:0ca53a7698b27956fbeb840684f31b6ca159a17e
parent a48fd8f1
......@@ -57,3 +57,271 @@
;; TODO wrapper for defining class wethod
)
(defwethod order ()
(let ((order (let/cc k
(save-k 'order 'order-form)
(%render-read-form 'order-form)
(return-from 'order))))
(if ((and (verify-order order)
(let/cc k
(save-k 'order 'confirm-order)
(%render-read-form 'confirm-order order)
(return-from 'order))))
(render 'show-invoice order))))
(defconthod order ()
(let ((order (read-form 'order-form)))
(print order)
(if ((and (verify-order order)
(read-form 'confirm-order order)))
(render 'show-invoice order))))
(defun verify-order (order)
(if (> order 10) t nil))
(defun confirm-order ()
t)
(defun place-order (order)
(print (list "hooray!" order)))
(defconthod order ()
(let ((order (read-form 'order-form)))
(if (and (verify-order order)
(read-form 'confirm-order order))
(place-order order)
(error "eeeek"))))
(order)
(kall (gethash '(order order-form) *ks*) 12)
(kall (gethash '(order confirm-order) *ks*) t)
(defparameter *ks* (make-hash-table :test #'equal))
(defun %render-read-form (form &rest args)
(print (list form args)))
(defun save-k (k name)
(print name)
(setf (gethash name *ks*) k))
(defmacro defconthod (name fn-list &body body)
;; add session id later.
`(defun ,name ,fn-list
(with-call/cc
(block ,name ;; block names outside with-call/cc are not visible inside.
(macrolet
((read-form (form &rest args)
(let ((k (gensym "k")))
`(let/cc ,k
(save-k ,k (list ',',name ,form))
(%render-read-form ,form ,@args)
(return-from ,',name)))))
,@body)))))
(deform some-form (object-type process-function &key (method :create))
(some-object some-string some-text some-number) ;; defines the returned values.
;; expression to produce the returned values.
(cons (if (eql method :create)
(create-object object-type some-object)
#+(or)(retrieve-object object-type some-object)
(error 'wisp-form-error
:field some-object
:msg "Cannot invoke this operation on object."))
(funcall process-function some-string some-text some-number))
;; wrapped in :wisp-form
(:input :name some-object :id 'some-object)
(:error some-object)
(:gaurd (not (== $some-string.value "")
(== $some-string.value $some-text.value))
:fail? (alert "something's wrong!") ;; immediate feedback
(:input :name some-string))
(:div :class 'form-error "Problem with some-string:"
(:error some-string)) ;; feedback from server.
(:div :class 'fancy-text-area
(:input some-text :type 'textarea :id 'some-text))
(:input some-number))
;; to use the form inside a control
(mvbind (some-object some-string some-text some-number) ;; expects bar-validator to return multiple values.
(read-form 'some-form 'foo-object-class #'bar-validator
:template 'some-template ;; renders the form in a template.
:template (in-template 'some-template ;; even fancier templating.
:form this ;;anaphoric reference to the form to be rendred.
;; :error form-errors ;;anaphoric... not a good idea? No. This is over the top.
:body (in-template 'some-other-template
:body (render-view 'some-silly-view)))
:method :create ;; pass on to the form for correct handling.
)
;; go on to do whatever
;; ;; this is pretty cool!
;; All I need to do now is to figure out how to implement this darn thing.
)
;; to use the form "raw"
(html (:html
(:body
(:wisp-form
:action "url/to/some-action"
#+ (or) (:render-form 'foo-object-class #'bar-validator :method create)
(:render-form 'foo-object-class #'bar-validator :method create)))))
(deform some-form ()
;; this is tricky. The form might post to different places if called
;; from different continuation points.
(:wisp-form
:action "somewhere" ;; if not specified, the url this form posts to depends on the render context.
;; the name property is mandatory. The id property is for javascript to get at the form.
;; Don't use the original html tags. Use something with more explicit type conversion.
(:object 'some-object :id 'some-object)
(:string 'some-string)
(:div :class 'fancy-text-area
(:string 'some-text :type 'text-area :id 'some-text))
(:number 'some-number)))
(deform some-form (object-type)
;; Given that forms are parameterizable, I can't use CLOS objects to represent them..
;;
;; What if I want to add validation? Where do I do it? Probably at the place where
;; form fields translate to data. It is conceivable that I want the same form to behave
;; differently.
;;
;; A functional interface for form makes it parameterizable, which I think is extremely
;; useful. But I don't know how to make extension easier. A "funcallable" form is very
;; composable.
;;
;; I don't think specifying the type here is such a clever idea.
(:object object-type :id 'some-object)
(:string 'some-string)
(:div :class 'fancy-text-area
(:string 'some-text :type 'textarea :id 'some-text))
(:number 'some-number)
;; nah, this is too hairy. It changes the return signature. Not good.
(if (equal (object-type) 'super-secure-object)
(render-form 'password-prompt)))
(deform some-form ()
(:object 'some-object :id 'some-object)
(:string 'some-string)
(:div :class 'fancy-text-area
(:string 'some-text :type 'textarea :id 'some-text))
(:number 'some-number))
(defclass wisp-form ()
(fields :initarg :fields))
(defclass wisp-form)
(defmacro deform (name fnlist &body body)
(with-collector (field-names)
(labels ((parse-form-field (form)
(if (null form) nil
(multiple-value-bind (tag attributes tag-body)
;; normalizes form before sending to html
;; parser. (Since we are using an irregular html form
;; that takes 1 required argument.)
(parse-cons-form (aif (form-field-tag? (car form))
;; the second element of the form field special form
;; is the name of the field. But it doesn't have :name
;; as its attribute key, so add that in.
(append (list it :name) (cdr form))
form))
(if (form-field-tag? tag)
(progn (field-names (cadr attributes))
(make-form-input name tag attributes tag-body))
;; recurse down the body to see if there is any
;; form field embedded within.
(cons tag (append attributes (mapcar #'parse-form-field tag-body)))))))
(form-field-tag? (tag)
(find tag '(:string :number :object))))
(list (mapcar #'parse-form-field body)
(field-names)))))
(defun make-form-input (form-name tag attributes tag-body)
(apply (rkr/fn (&key id type name &other-keys others)
`(,(^keyword (or (unquote type) :input))
:name ,(strcat "(" form-name " " (unquote name) ")")
,@(when id `(:id ,id))
,@others
,@tag-body))
attributes))
(apply (rkr/fn (&key id type name &other-keys others &rest rest)
`(,(or type :input)
:name ,(strcat "(" "some-form" " " name ")")
,@(when id `(:id ,id))
,@others
,@(list 1 2 3)))
'(:id 'ha :name 'la :style "blahblah"))
(:input :name "(some-form quotela)" :id 'ha :style "blahblah" 1 2 3)
(parse-cons-form '(:div :id 1 :a 2 :b 3 4 5 6))
(deform some-form ()
;; explicit declaration?
;; ;; Not a good idea. Doesn't gain much clarity or robustness.
(:wisp-form (some-object some-string some-text some-number)
(:object 'some-object :id 'some-object)
(:string 'some-string)
(:div :class 'fancy-text-area
(:string 'some-text :type 'text-area :id 'some-text))
(:number 'some-number)))
;; template
(let ((send-to (get-url some-wethod))
(send-method :post))
(html
(:div :class 'some-form
(:form :method send-method :action send-to
;; render the fields for user to initialize an object.
(:input :name "(some-form some-object-class)"
:id 'some-object-class)
(:input :name "(some-form some-object-field1)"
:id 'some-object-field1)
(:input :name "(some-form some-object-field2)"
:id 'some-object-field2)
;; ... among other fields.
(:input :name "(some-form some-string)")
(:div :class 'fancy-text-area
(:input :name "(some-form some-number)"
:id 'some-text))
(:input :name "(some-form some-text)")
))))
;; form handler
(let ((#:form (get-form 'some-form)))
(with-functional-interface-for-form #:form
(values (^string 'some-string)
(^string 'some-number)))
\ No newline at end of file
......@@ -22,59 +22,103 @@
(defun parse/rkr/fnlist (args)
(destructuring-bind (required keys other-keys body)
(split-by-separators args `(&key &other-keys
,(fn (arg) (member arg '(&body &rest)))))
,(fn (arg) (find arg '(&body &rest)))))
(list required
(mapcar #'mklst (cdr keys))
(cdr other-keys)
(cdr body))))
(defun parse/rkr/args (arg-list required-args valid-keys &key (other-keys? nil))
"Returns (list required keys other-keys rest)"
(flet ((valid-key? (key) (member-if (fn (key2) (equal (symbol-name key2) (symbol-name key)))
valid-keys)))
(defun parse/rkr/args (arg-list required-args valid-keys &key (other-keys? nil) (rest-args? nil))
"Returns (list required keys other-keys rest)"
(flet ((valid-key? (key) (find key valid-keys)))
(let* ((args-length (length required-args))
(required (subseq arg-list 0 args-length))
(keys/rest-args (subseq arg-list args-length)))
(if (and valid-keys (keywordp (car keys/rest-args)))
;; Extracts keys if there are valid-keys in the function signature,
;; and when the first element in the body is a keyword.
;;
;; Note that if the function doesn't take any keys, the first keyword
;; is taken as part of the body.
(if (null keys/rest-args) (list required nil nil nil)
(loop for (key arg . rest) on keys/rest-args by #'cddr
while (keywordp key)
if (valid-key? key) append (list key arg) into keys
if (not (keywordp key)) do (progn (setf rest (cons key (cons arg rest)))
(loop-finish))
else if (valid-key? key) append (list key arg) into keys
else if other-keys? append (list key arg) into other-keys
else do (error "Invalid key ~S in rkr lambda-list ~S" key arg-list) end
while (keywordp (car rest))
finally (return (list required keys other-keys rest)))
(list required nil nil keys/rest-args)))))
else do (error "Invalid key ~S for rkr lambda-list. ~S" key arg-list) end
finally (return
(if (and rest (not rest-args?))
(error "Too many arguments for rkr lambda-list. ~S. Maybe you forgot &rest?"
;; not very good error message...
arg-list)
(list required keys other-keys rest))))))))
;; (parse/rkr/args '(1 2)
;; '(a b)
;; nil
;; :rest-args? t)
;; ((1 2) nil nil nil)
;; (parse/rkr/args '(1 2)
;; '(a b)
;; nil)
;; ((1 2) nil nil nil)
;; (parse/rkr/args '(1 2 3 4)
;; '(a b)
;; nil)
;; ;; error
;; (parse/rkr/args '(:a 1 :b 2)
;; nil
;; '(:a :b)
;; :rest-args? t)
;; (nil (:a 1 :b 2) nil nil)
;; (parse/rkr/args '(:a 1 :b 2)
;; nil
;; '(:a :b))
;; (nil (:a 1 :b 2) nil nil)
;; (parse/rkr/args '(:a 1 :b 2 :c 3 :d 4)
;; nil
;; '(:a :b)
;; :other-keys? t)
;; (nil (:a 1 :b 2) (:c 3 :d 4) nil)
;; (parse/rkr/args '(:a 1 :b 2 :c 3 :d 4)
;; nil
;; '(:a :b)
;; :rest-args? t)
;; ;; error
;; (parse/rkr/args '(1 2 4 5 6 7)
;; '(arg1 arg2)
;; '(:a :b))
;; '(:a :b)
;; :rest-args? t)
;; ((1 2) nil nil (4 5 6 7))
;; (parse/rkr/args '(1 2 :a 3 :b 4 5 6 7)
;; '(arg1 arg2)
;; '(:a :b))
;; '(:a :b)
;; :rest-args? t)
;; ((1 2) (:a 3 :b 4) nil (5 6 7))
;; (parse/rkr/args '(1 2 :a 3 :b 4 :c 5 6 7)
;; '(arg1 arg2)
;; '(:a :b))
;; '(:a :b)
;; :rest-args? t)
;; ;; error
;; (parse/rkr/args '(1 2 :a 3 :e 6 :b 4 :c 5 6 7)
;; '(arg1 arg2)
;; '(:a :b)
;; :other-keys? t)
;; :other-keys? t
;; :rest-args? t)
;; ((1 2) (:a 3 :b 4) (:e 6 :c 5) (6 7))
;;
......@@ -93,10 +137,12 @@
(let* ((fn (dbind (required-args key-args other-keys rest) (parse/rkr/fnlist fnlist)
`(fn (&rest arg-list)
(flet ((bind-args ,(build/rkr/fnlist required-args key-args other-keys rest) ,@body))
(dbind (required keys other-keys rest)
(parse/rkr/args arg-list ',required-args ',(mapcar #'car key-args)
:other-keys? ',other-keys)
(let ((keys (append (when rest (list ,(^keyword (car rest)) rest))
(dbind (required keys other-keys rest-args)
(parse/rkr/args arg-list ',required-args ',(mapcar (compose #'^keyword #'car)
key-args)
:other-keys? ,(consp other-keys)
:rest-args? ,(consp rest))
(let ((keys (append (when rest-args (list ,(^keyword (car rest)) rest-args))
(when other-keys (list ,(^keyword (car other-keys)) other-keys))
keys)))
;; sneaks in rest and other-keys as if they are key args
......@@ -112,6 +158,7 @@
(:fn `,fn))))
(defmacro def/rkr/macro (name fnlist &body body)
`(def/rkr/fn-type :defmacro ,name ,fnlist ,@body))
......@@ -121,17 +168,24 @@
(defmacro rkr/fn (fnlist &body body)
`(def/rkr/fn-type :fn nil ,fnlist ,@body))
;; (funcall (rkr/fn (a b &key c d &rest rest) (list a b c d rest)) 1 2 :d 3 4 5)
;; (funcall (rkr/fn (a b &key c d &rest rest) (list a b c d rest)) 1 2 :d 3 4 5)
;; (1 2 nil 3 (4 5))
;; (funcall (rkr/fn (a b &key c d &other-keys e &rest rest) (list a b c d e rest)) 1 2 :d 4 7 8)
;; (1 2 nil 4 nil (7 8))
;; (funcall (rkr/fn (a b &key c d &other-keys e) (list a b c d e)) 1 2 :d 4 :e 7)
;; (funcall (rkr/fn (a b &key c d &other-keys e &rest rest) (list a b c d e rest)) 1 2 :d 4 :e 5 :f 6 7 8)
;; (1 2 nil 4 (:e 5 :f 6) (7 8))
;;
;;
;; (def/rkr/fun foo (a b &key c d &rest rest) (list a b c d rest))
;; (def/rkr/fun foo (a b &key c d &rest rest) (list a b c d rest))
;; (foo 1 2 :d 3 4 5)
......@@ -147,7 +201,8 @@
(list '&key keyarg)))
)
) ;; eval-when
;;; fmt macro
;;;; Issues
......
(defpackage :wisp-util (:use :cl :cl-ppcre :cl-interpol :kmrcl) ; :it.bese.fiveam)
(defpackage :wisp-util
(:use :cl :cl-ppcre :cl-interpol :arnesi :kmrcl) ; :it.bese.fiveam)
(:shadowing-import-from :arnesi
:it :copy-file :random-string
:quit :awhen :aand :acond :aif
:compose)
(:export
:split-by-separators
:^string
:^symbol
:^keyword
:^keyword
:unquote
:fn
:mklst
......@@ -42,6 +48,28 @@
;;kmrcl
:string-invert
;;arnesi
:curry
:rcurry
:conjoin
#:to-cps
#:with-call/cc
#:kall
#:call/cc
#:let/cc
#:*call/cc-returns*
#:invalid-return-from
#:unreachable-code
#:defun/cc
#:defgeneric/cc
#:defmethod/cc
#:fmakun-cc
#:*debug-evaluate/cc*
#:*trace-cc*
))
......@@ -49,9 +77,8 @@
(:use :cl :wisp-util
:com.gigamonkeys.foo
:elephant
:ele-bdb
:net.aserve
:kmrcl
;; :ele-bdb
:net.aserve
:mop
:cl-ppcre
:it.bese.fiveam)
......@@ -63,11 +90,9 @@
:retrieve
:print-object-content
;; wethod, wisplay, wobject. Hahaha...
;; wethod, wisplay, wobject. Hahaha...
)
(:import-from :elephant defpclass)
(:import-from :arnesi :curry :rcurry :conjoin))
(:import-from :elephant defpclass))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment