Commit f21476cb authored by hayeah via gmail com's avatar hayeah via gmail com

no-call/cc

- Continuation via aserve is *finally* working. Hurray!

darcs-hash:dbd4fe24158570b7e0c9b13aaea79328271ac49f
parent d63ad243
......@@ -22,6 +22,8 @@
(defmacro with-foo-output ((stream &key (pretty *pretty*)) &body body)
`(let* ((*text-output* ,stream)
(*pretty* ,pretty))
(declare (special *text-output*)
(special *pretty*))
,@body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
;; It might be interesting to have a `with-state' macro that
;; automatically clean-up all the continuations invovled after existing
;; the dynamic extent. The name `stately' is kinda interesting.
(in-package :wisp-mvc)
(defmacro test-wethod (form))
(defparameter *wisp-read-form-template-fns*
......@@ -81,7 +84,8 @@
fn-list))
`(render-view ,',name ,@args))))))
,@body))))
(save-wethod ',name)))
(save-wethod ',name)
',name))
......@@ -124,23 +128,41 @@
(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)
(return-from ,name)))))
(return-from ,name t)))))
;; (%read-form-macro foo 'foo-form 1 2 3)
;; (%read-form-macro moo :template (:html (:header this-form)) 'foo 'foo-form 1 2 3)
(defun %read-form (continuation-id form-name &rest form-args)
(respond-with-html (*html-out*)
(with-foo-output (*html-out*)
(render-form continuation-id form-name form-args))))
(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 ()
......
......@@ -11,18 +11,19 @@
,@others
,@(mapcar #'make-pane body))))
;; (:body
;; (:layout-div :child-priority "none" :style (:width 80% :height 300px)
;; (:top :style (:background red) "top")
;; (:bottom :style (:background $000000 :color $ffffff) "bottom")
;; (:left :style (:background $444444 :color $ffffff) "left")
;; (:right :style (:background $888888)"right")
;; (:top :style (:background $cccccc)"top 2")
;; (:right :style (:background green :color $ffffff) "right")
;; (:bottom :style (:background blue)"bottom 2")
;; (:left :style (:background yellow :color black) "left")
;; (:client :style (:text-align center)"How about 42?")))
;;
#+(or)
(:body
(:layout-div :child-priority "none" :style (:width 80% :height 300px)
(:top :style (:background red) "top")
(:bottom :style (:background $000000 :color $ffffff) "bottom")
(:left :style (:background $444444 :color $ffffff) "left")
(:right :style (:background $888888)"right")
(:top :style (:background $cccccc)"top 2")
(:right :style (:background green :color $ffffff) "right")
(:bottom :style (:background blue)"bottom 2")
(:left :style (:background yellow :color black) "left")
(:client :style (:text-align center)"How about 42?")))
(deftag :content-pane (&rest body)
`(:div :dojoType "ContentPane"
......@@ -47,13 +48,14 @@
,@others
,@body))
;; (:tab-div :layout-align 'top
;; (:pane :label "Tab 1" "0")
;; (:pane :href "/src/silly.txt" :label "Tab 2" "a")
;; (:pane :refresh-on-show 'false :label "Tab 3" "b")
;; (:tab-div :label "Nested Tab"
;; (:pane :label "Tab 3.1" "hi")
;; (:pane :label "Tab 3.2" "hello")))
#+(or)
(:tab-div :layout-align 'top
(:pane :label "Tab 1" "0")
(:pane :href "/src/silly.txt" :label "Tab 2" "a")
(:pane :refresh-on-show 'false :label "Tab 3" "b")
(:tab-div :label "Nested Tab"
(:pane :label "Tab 3.1" "hi")
(:pane :label "Tab 3.2" "hello")))
(deftag :accordion-div (&key label-class ;; for attaching style-sheet to the accordion label
div-class ;; for attaching style-sheet to the div container
......@@ -66,15 +68,16 @@
,@others
,@body))
;; (:body
;; (:css (.accBody :background white)
;; (.accLabel :background black :color white :border 1px solid white))
;; (:accordion-div :div-class 'acc-body :label-class 'acc-label
;; :style (:height 400px :width 300px :border 1px solid black)
;; (:pane :label "sect 1" :open 'true
;; (:div :style (:height 110px) "moohahaha"))
;; (:pane :label "sect 2" (:div "bwahahaha"))
;; (:pane :label "sect 3" (:div "mahahahahaha"))))
#+(or)
(:body
(:css (.accBody :background white)
(.accLabel :background black :color white :border 1px solid white))
(:accordion-div :div-class 'acc-body :label-class 'acc-label
:style (:height 400px :width 300px :border 1px solid black)
(:pane :label "sect 1" :open 'true
(:div :style (:height 110px) "moohahaha"))
(:pane :label "sect 2" (:div "bwahahaha"))
(:pane :label "sect 3" (:div "mahahahahaha"))))
(deftag :split-div (orientation &key (sizer-width 10) (active-sizing 0) &other-keys others &rest body)
......@@ -83,19 +86,19 @@
,@others
,@body))
(deftag :split-v (&body body)
`(:split-container "vertical" ,@body))
(deftag :split-v (&other-keys others &body body)
`(:split-div "vertical" ,@others ,@body))
(deftag :split-h (&body body)
`(:split-container "horizontal" ,@body))
(deftag :split-h (&other-keys others &body body)
`(:split-div "horizontal" ,@others ,@body))
#+(or)
(:split-v :style (:width 400px :height 400px :border 1px solid black)
(:content-pane "Hello1")
(:split-h
(:content-pane "Hello2")
(:content-pane "Hello3")))
;; (:split-v :style (:width 400px :height 400px :border 1px solid black)
;; (:content-pane "Hello1")
;; (:split-h
;; (:content-pane "Hello2")
;; (:content-pane "Hello3")))
;;
(deftag :tree (&key (toggle "fade") (size-min 20) (size-share 20) &rest trees)
......@@ -109,11 +112,12 @@
(cdr tree)))
`(:div :dojoType "TreeNode" :title ,tree)))
;; (:tree
;; ("Item1" "Item 1.1"
;; ("Item 1.2" "Item 1.2.1" "Item 1.2.2")
;; ("Item 1.3" "Item 1.3.1" "Item 1.3.2")
;; ("Item 1.4" "Item 1.4.1" "Item 1.4.2")))
#+(or)
(:tree
("Item1" "Item 1.1"
("Item 1.2" "Item 1.2.1" "Item 1.2.2")
("Item 1.3" "Item 1.3.1" "Item 1.3.2")
("Item 1.4" "Item 1.4.1" "Item 1.4.2")))
......
......@@ -5,24 +5,25 @@
(defparameter *wisp-form-handlers* (make-hash-table :test #'equal))
(defun render-form (continuation-id form-name form-args)
(defun render-form (k-id form-name 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 continuation-id))
(template (get-read-form-template-fn continuation-id)))
(register-form-handler (handler-fn form) continuation-id form-args)
(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)
(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)))))
;; insert the html (as string) for the form inside the provided template.
(with-call/cc (funcall template form-html)))
(apply (html-fn form) form-handler-url form-args))))
(render-html (with-call/cc (funcall template form-html))))
(render-html (apply (html-fn form) form-handler-url form-args)))))
(defun make-form-handler-url (continuation-id)
(strcat "/khandler?k-id=" (^string continuation-id)))
(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*)
......@@ -31,7 +32,10 @@
(apply handler-fn k-id form-args)))))
(defun call-form-handler (k-id)
(funcall (gethash form-handler-url *wisp-form-handlers*)))
(aif (gethash k-id *wisp-form-handlers*)
(funcall it)
(error "invalid continuation.")))
......@@ -62,8 +66,8 @@
(defun make-form-handler (form-name fn-list values handler)
(let ((continuation-id (gensym "continuation-id")))
`(fn ,(append (list continuation-id) fn-list)
(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)
......
......@@ -3,7 +3,8 @@
(defun attach-urlmap (url-prefix map-name)
"Registers a urlmap under the provided url-prefix."
(let ((map (get-urlmap map-name)))
(let ((map (get-urlmap map-name))
(url-prefix (ensure-prefix-slash-only url-prefix)))
(detect-circular-map-nesting map)
(with-slots (url-prefixes) map
(setf url-prefixes (adjoin url-prefix url-prefixes)))
......@@ -50,19 +51,37 @@
(publish-prefix :prefix url
:function nil)))
(defun ^url-dispatcher (url-prefix urlmap)
(fn (*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*)))
(declare (special *parameters*))
(match-url-dispatch
;; get rid of the heading `/'
(remove-url-prefix (net.uri:uri-path (request-uri *request*)) url-prefix)
urlmap))))
(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)
......
......@@ -2,6 +2,30 @@
;; process has linear runtime wrt to the number of possible matches...
;;
;; TODO Fix linear run-time.
;; It's hard... I have to use pattern matching, yet garuantee some
;; sort of linear ordering. Wait till later.
;; "/pk/qux/number_1/number_2/number_3"
;; ("pk" "qux" ("number" "1") ("number" "2") ("number" "3"))
;; (nil nil arg1 arg2 arg3)
;; "/wethod/class1_arg1/class2_arg2"
;; ("wethod" ("class1" "arg1") ("class2" "arg2"))
;; (nil arg1 arg2)
;; "/fn/arg1/arg2"
;; ("fn" "arg1" "arg2")
;; (nil arg1 arg2)
;; ;; => "arg1", "arg2"
;; "/fn/arg1/arg2"
;; ("fn" "arg1" "arg2")
;; (arg1 arg2 arg3)
;; ;; => "fn", "arg1", "arg2"
(in-package :wisp-mvc)
......@@ -59,7 +83,7 @@
(match-url-dispatch it (get-urlmap nested-map-name) :nested? nested?)))))
(dolist (map (butlast url-nested-maps))
(awhen2 (match-rec map :nested? t)
(return-from match-nested-urlmap (values it t))))
(return-from match-nested-urlmaps (values it t))))
;; tail-recurse to the last nested urlmap
(aand (last1 url-nested-maps) (match-rec it :nested? nested?))))
......
......@@ -3,6 +3,9 @@
(in-package :wisp-mvc)
(defun request-url-explode (url)
)
(defparameter *urlmaps* (make-hash-table :test #'equal))
(defclass urlmap ()
......@@ -167,7 +170,7 @@ Series of empty strings \"\" results in empty string. "
(defun get-effective-urls (map-name)
(unparse-urlmap (get-urlmap map-name)))
(awhen (get-urlmap map-name) (unparse-urlmap it)))
(defmacro defurlmap (map-name &rest url-specs)
......
(in-package :wisp-mvc)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *defined-views* (make-hash-table :test #'equal))
(defparameter *html-output-stream* *standard-output*)
(defparameter *request* nil)
;; (defmacro respond-with-html ((stream-name) &body body)
;; `(let ((html-response
;; (let ((,stream-name (make-string-output-stream)))
;; (declare (special ,stream-name))
;; (unwind-protect
;; (handler-case (progn ,@body (get-output-stream-string ,stream-name))
;; (werror (c)
;; ;; bind a fresh output stream
;; (close ,stream-name) (setf ,stream-name (make-string-output-stream))
;; (fmt :> ,stream-name
;; "Unhandled Error Signaled." :%)
;; (print c ,stream-name)
;; (get-output-stream-string ,stream-name)))
;; (close ,stream-name)))))
;; ;; probably can use copy-stream instead.
;; (if *request*
;; ;; if is serving a html request
;; (with-http-response (*request* *entity*)
;; (with-http-body (*request* *entity*)
;; (let ((out (request-reply-stream *request*)))
;; (write-string html-response out))))
;; ;; or is debugging in lisp
;; (write-string html-response *standard-output*))))
(defmacro respond-with-html ((stream-name) &body body)
`(let ((html-response
(let ((,stream-name (make-string-output-stream)))
(declare (special ,stream-name))
(unwind-protect
(handler-case (progn ,@body (get-output-stream-string ,stream-name))
(werror (c)
;; bind a fresh output stream
(close *html-output-stream*) (setf ,stream-name (make-string-output-stream))
(fmt :> *html-output-stream*
"Unhandled Error Signaled." :%)
(print c ,stream-name)
(get-output-stream-string ,stream-name)))
(close ,stream-name)))))
;; probably can use copy-stream instead.
(if *request*
;; if is serving a html request
(with-http-response (*request* *entity*)
(with-http-body (*request* *entity*)
(let ((out (request-reply-stream *request*)))
(write-string html-response out))))
;; or is debugging in lisp
(write-string html-response *standard-output*))))
;; TODO put the body in a flet.
`(no-call/cc
(if *request*
;; if is serving a html request
(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))))
......@@ -80,6 +98,12 @@
(with-foo-output (*html-output-stream*)
(html ,@body))))
(defgeneric render-error (werror))
(defmethod render-error ((werror werror))
(render-html (:html (:title "Error. " werror)
(:body (:div "Unhandled error: " werror)))))
;; (defview object->html ((obj wisp-object))
;; (let* ((class (class-of obj))
;; ;; I was hoping to use the existence of reader and writer as flag for permission of read/write
......@@ -113,7 +137,7 @@
`(save-template-fn ',template-name
(rkr/fn ,fnlist ,@body)))
) ;; eval-when
;; (deftemplate foo (&key (header "bullshit")
......
......@@ -5,81 +5,147 @@
:copy-file :random-string
:quit
:compose)
(:import-from :arnesi
:no-call/cc-form
:no-call/cc)
(:shadowing-import-from :cl-ppcre :quote-meta-chars)
(:import-from :kmrcl :awhen :aand :acond :aif :awhen2 :aif2 :acond2 )
(:export
:split-by-separators
:^string
:^symbol
:^keyword
:unquote
:fn
:mklst
:strcat
:symcat
:mappend
:group
:mvbind
:mvsetq
:dbind
;; list
:last1
:filter
:split-if
;;anaphoric macros
:self
:it
:awhen
:aif
:afn
:aif2
:awhen2
:acond2
:aand
;; rkr/macro
:def/rkr/macro
:def/rkr/fun
:rkr/fn
:&other-keys
;; regex
:=~
:$
:$b
:$m
:$a
;; fmt
:fmt
;; kmrcl
:string-invert
:list-to-delimited-string
;; arnesi
:curry
:rcurry
:conjoin
:compose
;; reducer/collector
#:make-reducer
#:make-pusher
#:make-collector
#:with-reducer
#:with-collector
#:with-collectors
;; call/cc
#: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*
))
(:shadowing-import-from :kmrcl
:it :awhen :aand :acond :aif :awhen2 :aif2 :acond2)
(:export
:intersection-in-order
:split-by-separators
:^string
:^symbol
:^keyword
:unquote
:fn
:mklst
:strcat
:symcat
:mappend
:group
:mvbind
:mvsetq
:dbind
;; list
:last1
:filter
:split-if
;;anaphoric macros
:self
:it
:awhen
:aif
:afn
:aif2
:awhen2
:acond2
:aand
;; rkr/macro
:def/rkr/macro
:def/rkr/fun
:rkr/fn
:&other-keys
;; regex
:=~
:$
:$b
:$m
:$a
;; fmt
:fmt
;; kmrcl
:string-invert
:list-to-delimited-string
;; arnesi
:curry
:rcurry
:conjoin
:compose
;; reducer/collector
#:make-reducer
#:make-pusher
#:make-collector
#:with-reducer
#:with-collector
#:with-collectors
;; walker
#:walk-form
#:make-walk-env
#:*walk-handlers*
#:*warn-undefined*
#:defwalker-handler
#:implicit-progn-mixin
#:implicit-progn-with-declare-mixin
#:binding-form-mixin
#:declaration-form
#:constant-form
#:variable-reference
#:local-variable-reference
#:local-lexical-variable-reference
#:free-variable-reference
#:application-form
#:local-application-form
#:lexical-application-form
#:free-application-form
#:lambda-application-form
#:function-form
#:lambda-function-form
#:function-object-form
#:local-function-object-form
#:free-function-object-form
#:lexical-function-object-form
#:function-argument-form
#:required-function-argument-form
#:specialized-function-argument-form
#:optional-function-argument-form
#:keyword-function-argument-form
#:allow-other-keys-function-argument-form
#:rest-function-argument-form
#:block-form
#:return-from-form
#:catch-form
#:throw-form
#:eval-when-form
#:if-form
#:function-binding-form
#:flet-form
#:labels-form
#:variable-binding-form
#:let-form
#:let*-form
#:locally-form
#:macrolet-form
#:multiple-value-call-form
#:multiple-value-prog1-form
#:progn-form
#:progv-form
#:setq-form
#:symbol-macrolet-form
#:tagbody-form
#:go-tag-form
#:go-form
#:the-form
#:extract-argument-names
#:walk-lambda-list
#:unwalk-form
;; call/cc
:no-call/cc
#: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*
))
(defpackage :wisp-sys
......
This diff is collapsed.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; These will never work
;;
;; No good way to convert closure/cc to ordinary closures.
;; (with-call/cc (let ((a (lambda () 1)))
;; (no-call/cc (funcall a))))
;;
;; (with-call/cc (let ((a (lambda () 1)))
;; (flet ((a () (funcall a)))
;; (no-call/cc (a)))))
(in-package :arnesi)
(with-call/cc (no-call/cc 1))
1
(type-of (with-call/cc (no-call/cc #'(lambda ()))))
function
(defparameter c 3)
(defun d ()
(declare (special d))
d)
(let ((a 1))
(with-call/cc (equal a
;; local-lexical-reference
(no-call/cc a))))
t
(with-call/cc (equal c
;; global-variable
(no-call/cc c)))
t
(with-call/cc (let ((d 2))
(declare (special d))
(equal (d)
;; special-variable
(no-call/cc (d)))))
t
(let ((d 2))
(declare (special d))
(with-call/cc (equal (d)
;; special-variable
(no-call/cc (d)))))
t
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;