Commit 15b0ab05 authored by hayeah via gmail com's avatar hayeah via gmail com

Form continuation.

darcs-hash:99bd5ed6a1a26960cfbc2737483bb1544bfce461
parent f21476cb
......@@ -7,34 +7,58 @@
(defmacro test-wethod (form))
(defparameter *wisp-read-form-template-fns*
(make-hash-table :test #'equal))
;; (defparameter *wisp-read-form-template-fns*
;; (make-hash-table :test #'equal))
(defun get-read-form-template-fn (k-id)
(gethash k-id *wisp-read-form-template-fns*))
;; (defun get-read-form-template-fn (k-id)
;; (gethash k-id *wisp-read-form-template-fns*))
(defun save-read-form-template-fn (k-id read-form-template-fn)
(setf (gethash k-id *wisp-read-form-template-fns*)
read-form-template-fn))
;; (defun save-read-form-template-fn (k-id read-form-template-fn)
;; (setf (gethash k-id *wisp-read-form-template-fns*)
;; read-form-template-fn))
(defparameter *wisp-continuations* (make-hash-table :test #'equal))
(defparameter *wisp-ks* (make-hash-table :test #'equal))
(defparameter *k-id* nil
"The id of the running continuation.")
(defun save-wisp-continuation (k-id k)
(setf (gethash k-id *wisp-continuations*) k))
(let ((counter 0))
(defun fresh-k-id (method-name form-name)
(princ-to-string (incf counter))))
(defun get-wisp-continuation (k-id)
(gethash k-id *wisp-continuations*))
(defun save-wisp-k (k-id k type &rest data)
(setf (gethash k-id *wisp-ks*) (list* k type *package* data)))
(defun get-wisp-k (k-id)
(gethash k-id *wisp-ks*))
(defun call-wisp-k (k-id &rest values)
;; probably want to trap form errors here.
(destructuring-bind (k type package . data) (get-wisp-k k-id)
(let ((*package* package)
(*k-id* k-id))
(unless k (error 'wisp-invalid-continuation-id))
(case type
(:form
(let ((mvlist (multiple-value-list (funcall (car data)))))
(if (cdr mvlist)
(apply #'kall k mvlist)
(funcall #'kall k (car mvlist)))))
(t (apply #'kall (cons k values)))))))
(defun save-form-k (k-id k handler-fn)
(save-wisp-k k-id k :form handler-fn))
(defun call-form-k (k-id)
(call-wisp-k k-id))
(defun call-wisp-continuation (k-id value)
;; kall doesn't support multiple values.
(kall (get-wisp-continuation k-id) value))
(let ((counter 0))
(defun get-continuation-id (method-name form-name)
(princ-to-string (incf counter))))
......@@ -62,30 +86,30 @@
(defmacro defwethod (name fn-list &body body)
;; TODO combine this with defwethod
;; add session id later.
`(progn
(defmethod ,name ,fn-list
(with-call/cc
(block ,name ;; block names outside with-call/cc are not visible inside.
(macrolet
((read-form (&rest args) `(%read-form-macro ,',name ,@args))
(render (&rest args)
`(respond-with-html (*html-out*)
(with-foo-output (*html-out*)
,(if (null args)
'(render-view ',name ,@(mapcar (fn (arg-spec)
(if (consp arg-spec)
(car arg-spec)
arg-spec))
fn-list))
`(render-view ,',name ,@args))))))
,@body))))
(save-wethod ',name)
',name))
;; The web-server doesn't know the package of this wethod.
(let ((*package* (find-package ,(package-name *package*))))
(with-call/cc
(block ,name ;; block names outside with-call/cc are not visible inside.
(macrolet
((read-form (&rest args) `(%read-form-macro ,',name ,@args))
(render (&rest args)
`(respond-with-html (*html-out*)
(with-foo-output (*html-out*)
,(if (null args)
'(render-view ',name ,@(mapcar (fn (arg-spec)
(if (consp arg-spec)
(car arg-spec)
arg-spec))
fn-list))
`(render-view ,',name ,@args))))))
,@body))))
(save-wethod ',name)
',name)))
......@@ -124,17 +148,25 @@
#+(or)(form (gensym "form"))
)
`(let/cc ,k
(let ((,k-id (get-continuation-id ',name ,form-name)))
(save-wisp-continuation ,k-id ,k)
,(when template
;; how expensive is it to create call/cc closures?
;; TODO memoizing actually must occur at runtime.
`(save-read-form-template-fn ,k-id
;; note this closure would capture variables.
(fn (this-form-html-string)
(symbol-macrolet ((this-form (html (:noescape this-form-html-string))))
(html ,template)))))
(%read-form ,k-id ,form-name ,@form-args)
(let ((,k-id (fresh-k-id ',name ,form-name)))
;; ,(when template
;; ;; how expensive is it to create call/cc closures?
;; ;; TODO memoizing actually must occur at runtime.
;; `(save-read-form-template-fn ,k-id
;; ;; note this closure would capture variables.
;; (fn (this-form-html-string)
;; (symbol-macrolet ((this-form (html (:noescape this-form-html-string))))
;; (html ,template)))))
(render-form ,k-id
,k
,(if template
`(no-call/cc
(fn (this-form-html-string)
(symbol-macrolet ((this-form (html (:noescape this-form-html-string))))
(html ,template))))
nil)
,form-name
,@form-args)
(return-from ,name t)))))
......@@ -142,55 +174,9 @@
;; (%read-form-macro moo :template (:html (:header this-form)) 'foo 'foo-form 1 2 3)
(defun %read-form (k-id form-name &rest form-args)
(render-form k-id form-name form-args))
(defun wisp-k-handler (k-id)
(call-form-handler k-id))
;; (defun moo ()
;; (html (:p 1 2 3)))
;; (render-html (:div (moo)))
;; (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)
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
......
(in-package :wisp-mvc)
(defmacro deform (name fn-list values handler &rest html)
;; use rkr macro?
`(setf (gethash ,(^string name) *wisp-forms*)
(make-instance 'wisp-form
:handler-fn ,(make-form-handler name fn-list values handler)
:html-fn ,(make-form-html-fn name fn-list values html))))
(defclass wisp-form ()
((handler-fn :initarg :handler-fn :reader handler-fn)
(html-fn :initarg :html-fn :reader html-fn)))
(defparameter *wisp-forms* (make-hash-table :test #'equal))
(defun get-wisp-form (name)
(gethash (^string name) *wisp-forms*))
;; closure for form handler
(defun make-form-handler (form-name fn-list values handler)
(let ((k-id (gensym "k-id")))
;; is it a good idea to introduce anaphoric for k-id?
`(fn ,(append (list 'k-id) fn-list)
,(with-form-values form-name values handler))))
(defun with-form-values (form-name values handler)
`(let (,@(mapcar (fn (value)
`(,value (param '(,form-name ,value))))
values))
,handler))
(multiple-value-list (list 1))
(defun get-form-value (form-name value)
(list form-name value))
;; closure for form html
(defun make-form-html-fn (form-name fn-list values html)
(let ((form-handler-url (gensym "handler-url")))
`(fn ,(append (list 'k-id) fn-list)
,(with-form-field-names form-name values
(make-wisp-form html)))))
(defun with-form-field-names (form-name values html)
;; what's the point of accumulating the fields of a form into one hash, as in RoR?
`(let (,@(mapcar (fn (value)
`(,value (strcat "(" ',form-name " " ',value ")")))
values))
,html))
(defun make-wisp-form (html)
`(html
(:wisp-form :action (make-form-k-url k-id)
;; or I can specify a keyword argument :form-handler-url in the official
;; interface to the read-form macro.
:method 'post
,@html)))
(defun make-form-k-url (k-id)
;; Don't know how to make the handler url dynamically configurable.
(strcat "/wisp-sys/form-k/" (^string k-id)))
\ No newline at end of file
......@@ -3,108 +3,29 @@
;; rendering forms and suspend in continuation
(defparameter *wisp-form-handlers* (make-hash-table :test #'equal))
(defun render-form (k-id form-name form-args)
(defun render-form (k-id k template form-name &rest form-args)
;; responsible for setting up the continuation, and registering the handler as the callback.
(let (#+(or)(session (get-session))
(form (get-wisp-form form-name))
(form-handler-url (make-form-handler-url k-id))
(template (get-read-form-template-fn k-id)))
(register-form-handler (handler-fn form) k-id form-args)
(form (get-wisp-form form-name)))
(save-form-k k-id k
(apply #'curry (handler-fn form) k-id form-args))
(if template
(let ((form-html
(with-output-to-string (*form-html-string*)
(with-foo-output (*form-html-string*)
(apply (html-fn form) form-handler-url form-args)))))
(apply (html-fn form) k-id form-args)))))
;; insert the html (as string) for the form inside the provided template.
(render-html (with-call/cc (funcall template form-html))))
(render-html (apply (html-fn form) form-handler-url form-args)))))
(render-html (funcall template form-html)))
(render-html (apply (html-fn form) k-id form-args)))))
(defun make-form-handler-url (k-id)
;; Don't know how to make the handler url dynamically configurable.
(strcat "/wisp-sys/khandler/" (^string k-id)))
(defun register-form-handler (handler-fn k-id form-args)
(setf (gethash k-id *wisp-form-handlers*)
(fn () (call-wisp-continuation k-id
;; probably want to trap form errors here.
(apply handler-fn k-id form-args)))))
(defun call-form-handler (k-id)
(aif (gethash k-id *wisp-form-handlers*)
(funcall it)
(error "invalid continuation.")))
;; defining forms
(defmacro deform (name fn-list values handler &rest html)
;; use rkr macro?
`(setf (gethash ,(^string name) *wisp-forms*)
(make-instance 'wisp-form
:handler-fn ,(make-form-handler name fn-list values handler)
:html-fn ,(make-form-html-fn name fn-list values html))))
(defclass wisp-form ()
((handler-fn :initarg :handler-fn :reader handler-fn)
(html-fn :initarg :html-fn :reader html-fn)))
(defparameter *wisp-forms* (make-hash-table :test #'equal))
(defun get-wisp-form (name)
(gethash (^string name) *wisp-forms*))
(defun make-form-handler (form-name fn-list values handler)
(let ((k-id (gensym "k-id")))
`(fn ,(append (list k-id) fn-list)
,(with-form-values form-name values handler))))
(defun with-form-values (form-name values handler)
`(let (,@(mapcar (fn (value)
`(,value (get-form-value ',value ',form-name)))
values))
,handler))
(defun get-form-value (form-name value)
(list form-name value))
(defun make-form-html-fn (form-name fn-list values html)
(let ((form-handler-url (gensym "handler-url")))
`(fn ,(append (list form-handler-url) fn-list)
,(with-form-field-names form-name values
(make-wisp-form html form-handler-url)))))
(defun with-form-field-names (form-name values html)
;; what's the point of accumulating the fields of a form into one hash, as in RoR?
`(let (,@(mapcar (fn (value)
`(,value (strcat "(" ',form-name " " ',value ")")))
values))
,html))
(defun make-wisp-form (html form-handler-url)
`(html
(:wisp-form :action ,form-handler-url
;; or I can specify a keyword argument :form-handler-url in the official
;; interface to the read-form macro.
:method 'post
,@html)))
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
......
......@@ -53,45 +53,4 @@
(defun ^url-dispatcher (url-prefix urlmap)
(if *wisp-debug*
(fn (*request* *entity*)
;; recreate the dispatcher so I don't have to re-attach the
;; urlmap everytime I modify %url-dispatcher fo easier debugging.
(funcall (curry #'%url-dispatcher url-prefix urlmap *request* *entity*)))
(fn (*request* *entity*)
(%url-dispatcher url-prefix urlmap *request* *entity*))))
(defun %url-dispatcher (url-prefix urlmap *request* *entity*)
(declare (special *request*) (special *entity*))
;; setup the dynamic enviornment that allows functional interface to http request.
;; *cookies*
;; *parameters*
;; *session*
(let ((*parameters* (parse-request-parameters (request-query *request*)))
(*readtable* *readtable*))
(declare (special *parameters*))
(setf (readtable-case *readtable*) :invert)
#+(or)(print "fuck this")
(handler-case
(match-url-dispatch
(remove-url-prefix (net.uri:uri-path (request-uri *request*)) url-prefix)
urlmap)
(werror (c)
(render-error c)))))
(defun remove-url-prefix (url url-prefix)
(=~ url-prefix url $a))
(defparameter *parameters* nil)
(defun parse-request-parameters (alist)
alist)
(defun param (key)
;; this is awful...
(cdr (assoc (^string key) *parameters*)))
......@@ -30,6 +30,59 @@
(in-package :wisp-mvc)
(defun ^url-dispatcher (url-prefix urlmap)
(if *wisp-debug*
(fn (*request* *entity*)
;; recreate the dispatcher so I don't have to re-attach the
;; urlmap everytime I modify %url-dispatcher fo easier debugging.
(funcall (curry #'%url-dispatcher url-prefix urlmap *request* *entity*)))
(fn (*request* *entity*)
(%url-dispatcher url-prefix urlmap *request* *entity*))))
(defun %url-dispatcher (url-prefix urlmap *request* *entity*)
(declare (special *request*) (special *entity*))
;; setup the dynamic enviornment that allows functional interface to http request.
;; *cookies*
;; *parameters*
;; *session*
;;
;; Be *really* careful about package issues. A wethod will set
;; *package* to be the package where it's defined. In general,
;; things should work as expected as long as all http-data stuff
;; are strings.
(let ((*parameters* (parse-request-parameters (request-query *request*)))
(*readtable* *readtable*))
(declare (special *parameters*))
(setf (readtable-case *readtable*) :invert)
#+(or)(print "fuck this")
(handler-case
(match-url-dispatch
(remove-url-prefix (net.uri:uri-path (request-uri *request*)) url-prefix)
urlmap)
(werror (c)
(render-error c)))))
(defun remove-url-prefix (url url-prefix)
(=~ url-prefix url $a))
(defparameter *parameters* nil)
(defun parse-request-parameters (alist)
alist)
(defun param (key)
;; this is awful...
(cdr (assoc (^string key) *parameters*
:test #'equal)))
(defun match-url-dispatch (request-url urlmap &key (nested? nil))
"Matches the request url against urlmap, then apply the dispatch function."
;; expects the request-url not be prepended with `/'
......
......@@ -32,19 +32,19 @@
(defmacro respond-with-html ((stream-name) &body body)
;; TODO put the body in a flet.
`(no-call/cc
(if *request*
;; if is serving a html request
`(if *request*
;; if is serving a html request
(no-call/cc
(with-http-response (*request* *entity*)
(with-http-body (*request* *entity*)
;; there really shouldn't be application errors when rendering the output.
;; If error IS signaled, I have no idea how aserve will behave.
(let ((,stream-name (request-reply-stream *request*)))
,@body)))
;; or is debugging in lisp
(let ((,stream-name *standard-output*))
(declare (special ,stream-name))
,@body))))
,@body))))
;; or is debugging in lisp
(let ((,stream-name *standard-output*))
(declare (special ,stream-name))
,@body)))
......
......@@ -54,6 +54,7 @@
:$a
;; fmt
:fmt
:*fmt-stream*
;; kmrcl
:string-invert
:list-to-delimited-string
......@@ -62,6 +63,7 @@
:rcurry
:conjoin
:compose
:eval-always
;; reducer/collector
#:make-reducer
#:make-pusher
......
......@@ -61,44 +61,55 @@
(defparameter *nesting-no-call/cc?* nil)
(defwalker-handler no-call/cc (form parent env)
"Makes the closure to be run in normal lisp mode.
`setf/q' doesn't work across the call boundary."
(with-form-object (no-call/cc no-call/cc-form :parent parent :source form)
(let* ((body-source (cons 'progn (cdr form)))
(body (walk-form (cons 'progn body-source) parent env))
(closure-body (walk-form body-source nil nil))
(local-vars (collect-local-vars body))
(free-vars (collect-free-vars closure-body))
(lex-vars (intersection local-vars free-vars :key #'name))
;; ;; I found out later that I need all the special-variables found at runtime.
#+(or)(dyn-vars (set-difference free-vars lex-vars :key #'name))
(free-apps (collect-free-apps closure-body))
(local-apps (collect-local-apps body))
(lex-apps (intersection local-apps free-apps :key #'operator)))
(when lex-apps (error "Damn, this is impossible! Can't refer to local functions estabalished in call/cc"))
;; We find all the free variables in the closure body. Some of
;; these are lexical variables established outside the closure
;; body (others are special variables).
;;
;; We need to pass in the lexical variables established outside
;; the closure as arguments to the closure. This set of
;; variables are those that appear to be free in the
;; closure-body, but are actually local-variables. (The
;; intersection of free-vars and local-vars).
;;
;; Geez. This is really hard to document. I can't explain it in
;; a way that I can understand 3 months from now.
;;
;; Doesn't capture complicated dependencies.
(setf (lex-vars no-call/cc) lex-vars
;;(dyn-vars no-call/cc) dyn-vars
(closure no-call/cc)
(eval #+(or)(print `(lambda ,(mapcar #'name lex-vars)
,(no-call/cc-fn-binds lex-apps body-source env)))
`(lambda ,(mapcar #'name lex-vars)
,(no-call/cc-fn-binds lex-apps body-source env))
)))))
(block fn-block
(when *nesting-no-call/cc?* (return-from fn-block))
;; all nested no-call/cc are ignored
(let ((*nesting-no-call/cc?* t))
(with-form-object (no-call/cc no-call/cc-form :parent parent :source form)
(let* ((body-source (cons 'progn (cdr form)))
(body (walk-form (cons 'progn body-source) parent env))
(closure-body (walk-form body-source nil nil))
(local-vars (collect-local-vars body))
(free-vars (collect-free-vars closure-body))
(lex-vars (intersection local-vars free-vars :key #'name))
;; ;; I found out later that I need all the special-variables found at runtime.
#+(or)(dyn-vars (set-difference free-vars lex-vars :key #'name))
(free-apps (collect-free-apps closure-body))
(local-apps (collect-local-apps body))
(lex-apps (intersection local-apps free-apps :key #'operator)))
(when lex-apps (error "Damn, this is impossible! Can't refer to local functions estabalished in call/cc"))
;; We find all the free variables in the closure body. Some of
;; these are lexical variables established outside the closure
;; body (others are special variables).
;;
;; We need to pass in the lexical variables established outside
;; the closure as arguments to the closure. This set of
;; variables are those that appear to be free in the
;; closure-body, but are actually local-variables. (The
;; intersection of free-vars and local-vars).
;;
;; Geez. This is really hard to document. I can't explain it in
;; a way that I can understand 3 months from now.
;;
;; Doesn't capture complicated dependencies.
(setf (lex-vars no-call/cc) lex-vars
;;(dyn-vars no-call/cc) dyn-vars
(closure no-call/cc)
(eval #+(or)(print `(lambda ,(mapcar #'name lex-vars)
,(no-call/cc-fn-binds lex-apps body-source env)))
`(lambda ,(mapcar #'name lex-vars)
;; use macrolet to ignore all nesting no-call/cc's
,(no-call/cc-fn-binds lex-apps body-source env))
)))))))
(defmacro no-call/cc (&rest body)
"Used to get rid of any nesting no-call/cc, or those that don't appear within with-call/cc."
`(progn ,@body))
;; by the time I am done with this, I would've written apt-get...
;; I give up.
......
......@@ -11,6 +11,8 @@
(in-package :arnesi)
(with-call/cc (no-call/cc (list 1 (no-call/cc 2))))
(1 2)
(with-call/cc (no-call/cc 1))
1
......
......@@ -4,15 +4,44 @@
;;
(in-package :wisp-mvc)
;; (defmethod foo (a b)
;; (render-html (:html (:print (list 'foo a b)))))
;; (defmethod foo ((arg1 class1) arg2)
;; (render-html (:html (:print
;; (list 'foo
;; (with-slots (a b) arg1
;; (list arg1 a b))
;; arg2)))))
;; (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)
......@@ -24,7 +53,7 @@
(defurlmap wisp-sys
("khandler/:k-id" :handler wisp-k-handler)
("form-k/:k-id" :handler call-form-k)
("test" :package :wisp-mvc))
(attach-urlmap "wisp-sys" 'wisp-sys)
......@@ -57,23 +86,23 @@
(defwethod foo ()
(let ((answer (read-form 'foo-form 3 4)))
(render-html (:html (:div "hurray")
(:div answer)))))
(kall (get-wisp-continuation "6") 1)
(call-wisp-continuation "6" '(a b c))
(:div answer)
(:div (show-request))))))
(call-wisp-continuation "1" 10)
(defun show-request ()
(html *parameters*
(:br)
*package*
(type-of (caar *parameters*))
(param '(foo-form some-object))
(:br)
*request*
*k-id*))