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

Continuation based flow control.

- and src tree restructuring.

darcs-hash:406bfffa6c8fa52fbdf52b7f6ed137121b26c36e
parent 9a7e59ff
;;
;; Copyright (c) 2005, Gigamonkeys Consulting All rights reserved.
;;
(in-package :cl-user)
(defpackage :com.gigamonkeys.foo.text-output
(:use :cl)
(:export
:*pretty*
:*text-output*
:*text-pretty-printer*
:codegen-text
:embed-code
:embed-value
:freshline
:get-pretty-printer
:indent
:newline
:ops
:raw-string
:text-compiler
:toggle-indenting
:unindent
:with-foo-output))
(defpackage :com.gigamonkeys.foo.language
(:use :cl
:com.gigamonkeys.macro-utilities
:com.gigamonkeys.foo.text-output)
(:export
:comment
:compile-special-op-body
:define-macro
:define-special-operator
:embeddable-value-form
:emit
:environment
:expand-macro-form
:foo-syntax-error
:identifier
:input-package
:input-readtable
:language
:macro-form-p
:macro-symbol
:output-file-type
:parse-&environment
:process
:process-sexp
:process-special-form
:self-evaluating-p
:sexp->ops
:sexp-form-p
:special-form-p
:special-operator-symbol
:top-level-environment))
(defpackage com.gigamonkeys.foo.javascript
(:use :common-lisp
:com.gigamonkeys.foo
:com.gigamonkeys.macro-utilities
:com.gigamonkeys.utilities
:com.gigamonkeys.foo.text-output
:com.gigamonkeys.foo.language)
(:export
:*javascript*
:javascript
:define-javascript-macro
:javascript-gensym
:new-env
:method
;; Special operators
:!
:!=
:!===
:%
:%=
:&
:&&
:&=
:*
:*=
:+
:++
:+=
:-
:--
:-=
:/
:/=
:<
:<<
:<<=
:<=
:=
:==
:===
:>
:>=
:>>
:>>=
:>>>
:>>>=
:?
:@
:\|
:\|=
:\|\|
:^
:^=
:~
:augment-environment ;; doesn't map to javascript construct
:array
:block
:break
:comment
:continue
:delete
:do-while
:for
:function
:function
:if
:in
:instanceof
:label
:new
:object
:prog
:progn
:progn
:ref
:return
:switch
:throw
:try
:typeof
:var
:void
:while
:with
:fn
:js
:dash-to-intercap
))
(defpackage com.gigamonkeys.foo.lispscript
(:use :common-lisp
:com.gigamonkeys.foo.language
:com.gigamonkeys.foo.javascript)
(:shadow :=)
(:export :*lispscript*))
(defpackage :com.gigamonkeys.foo.css
(:use :common-lisp
:com.gigamonkeys.macro-utilities
:com.gigamonkeys.utilities
:com.gigamonkeys.foo.text-output
:com.gigamonkeys.foo.language
:com.gigamonkeys.foo.javascript)
(:export
:emit-css
:process-css-attributes
:css))
(defpackage :com.gigamonkeys.foo.html
(:use :common-lisp
:com.gigamonkeys.macro-utilities
:com.gigamonkeys.utilities
:com.gigamonkeys.foo.text-output
:com.gigamonkeys.foo.language
:com.gigamonkeys.foo.javascript
:com.gigamonkeys.foo.css)
(:export
:&attributes
:*block-elements*
:*paragraph-elements*
:cons-form-p
:define-html-macro
:define-html-special-operator
:emit-html
:emit-xml
:html
:in-html-style
:parse-cons-form
:with-html-output
:with-html-to-file
:xml
:deftag))
(defpackage com.gigamonkeys.foo.lispscript-tests
(:use :common-lisp
:com.gigamonkeys.foo
:com.gigamonkeys.foo.html
:com.gigamonkeys.foo.javascript
:com.gigamonkeys.foo.lispscript))
(defpackage com.gigamonkeys.foo.javascript.tokens (:use))
(defpackage com.gigamonkeys.foo.java
(:use :common-lisp
:com.gigamonkeys.foo
:com.gigamonkeys.macro-utilities
:com.gigamonkeys.utilities
:com.gigamonkeys.foo.text-output)
(:shadow
:type
:class
:package
:block)
(:export
:define-java-macro))
(defpackage :com.gigamonkeys.foo
(:use :common-lisp
:com.gigamonkeys.foo.html
:com.gigamonkeys.foo.css
:com.gigamonkeys.foo.javascript
:com.gigamonkeys.macro-utilities
:com.gigamonkeys.utilities
:com.gigamonkeys.foo.text-output
:com.gigamonkeys.foo.language)
(:export
:&attributes
:*block-elements*
:*paragraph-elements*
:compile-javascript
:cons-form-p
:css
:define-css-macro
:define-html-macro
:define-html-special-operator
:emit-css
:emit-html
:emit-javascript
:emit-xml
:generate-from-file
:generate-from-string
:html
:in-html-style
:javascript-gensym
:parse-cons-form
:process
:process-special-form
:with-foo-output
:with-html-output
:with-html-to-file
:xml
:js
:~
:@
:deftag
:fn
))
This diff is collapsed.
......@@ -7,10 +7,7 @@
;;; et al. into environment so we can define special operators to
;;; change their values at compile time.
(in-package :com.gigamonkeys.foo.html)
(use-package :com.gigamonkeys.foo.javascript)
(use-package :wisp-util)
(in-package :com.gigamonkeys.foo.html)
(defclass html (language)
()
......@@ -90,8 +87,16 @@
(let ((*escapes* *element-escapes*))
(codegen-text (sexp->ops *html* body nil) ,*pretty*))))
,@(if *pretty*
`((let ((*text-pretty-printer* (get-pretty-printer))) ,whole))
`(,whole))))
`((let ((*text-pretty-printer* (get-pretty-printer)))
;; redundant declaration for the benefit of arnesi call/cc
(declare (special *text-pretty-printer*))
,whole))
`(,whole))
(values)))
(defmethod expand-html-macro (form)
(let ((macro-function (get (identifier *html* form) (macro-symbol *html*))))
(funcall macro-function form (top-level-environment *html*))))
(defmacro xml (&whole whole &body body)
(declare (ignore body))
......@@ -138,7 +143,8 @@
(or (self-evaluating-p form) (cons-form-p form)))
(defmethod embeddable-value-form ((language html) form)
`(escape (princ-to-string ,form) ,*escapes*))
`(let ((val ,form))
(and val (escape (princ-to-string val) ,*escapes*))))
(defmethod process-sexp ((language html) processor form environment)
(declare (ignore environment))
......@@ -153,7 +159,8 @@
(and (consp form) (eql (car form) 'quote)))
(defmethod emit-self-evaluating-form (processor form)
(cond ((symbolp form) (emit-html-symbol processor form))
(cond ((null form) nil)
((symbolp form) (emit-html-symbol processor form))
((quoted-form? form)
(emit-self-evaluating-form processor (second form)))
(t (raw-string processor (escape (princ-to-string form) *escapes*) t))))
......@@ -201,7 +208,8 @@
(defun js-event? (attribute)
(or (eql attribute :href-js)
(equal (subseq (symbol-name attribute) 0 2) "ON")))
(and (>= (length (symbol-name attribute)) 2)
(equal (subseq (symbol-name attribute) 0 2) "ON"))))
(defun css-style? (tag)
(eql tag :style))
......@@ -226,8 +234,7 @@
(process-css-attributes processor v))
(raw-string processor "'"))
(t
(raw-string processor (fmt :> nil
" " (dash-to-intercap (^string k)) "='"))
(raw-string processor (fmt :> nil " " (dash-to-intercap (^string k)) "='"))
(process *html* processor (if (eql v t) k v) nil)
(raw-string processor "'"))))))
......@@ -298,49 +305,6 @@
(nconc (ldiff args attr-cons) (cddr attr-cons)))))
(defmacro deftag (name parameters &body body)
(destructuring-bind (required keys other-keys macro-body)
(split-by-separators parameters '(&key &other-keys &body))
`(define-foo/rkr/macro ,name html-macro (,@required
,@(awhen (cdr keys) `(&key ,@it))
,@(awhen (cdr other-keys) `(&other-keys ,@it))
,@(awhen (cdr macro-body) `(&body ,@it)))
,@body)))
(defmacro define-foo/rkr/macro (name macro-symbol (&rest parameters) &body body)
(with-gensyms (whole namevar)
(multiple-value-bind (parameters environment) (com.gigamonkeys.foo.language::parse-&environment parameters)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name ',macro-symbol)
(lambda (,whole ,environment)
(handler-case
(apply (rkr/fn (,@(com.gigamonkeys.foo.language::normalize-macro-lambda-list parameters namevar))
(declare (ignore ,namevar))
(declare (ignorable ,environment))
,@body)
,whole)
(error (e) (error 'foo-syntax-error :form ,whole :cause e)))))))))
;; (deftag :bar (a b c &key d &other-keys e &body body)
;; `(:span ,@e
;; (:b :id ,d (list ,a ,b ,c))
;; (:div ,@body)))
;; (apply (get :foo 'html-macro) '((:foo 1 2 3 10 11 12) nil))
;; (html (:foo 1 2 3 :d 3 (list 10 11 12)))
;; (html (:bar 1 2 3 :d 3 (list 10 11 12)))
;; (html (:bar 1 2 3 :d 3 :f 10 :g 20 (list 10 11 12)))
;; (funcall (rkr/fn (a &key ff &other-keys b &rest c) (list a b c)) 1 :b 2 :c 3 4 5 6)
;; (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)
;; (symbol-package 'rkr/fn)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Special Forms
......
......@@ -612,27 +612,27 @@ statements such as blocks to *not* emit a semicolon."
(loop for form in body do
(process *javascript* processor form env))))
(export '%if)
(remprop 'if 'javascript-special-operator)
(remprop 'if 'javascript-special-operator-type)
(export '%return)
(remprop 'return 'javascript-special-operator)
(remprop 'return 'javascript-special-operator-type)
(export '%block)
(remprop 'block 'javascript-special-operator)
(remprop 'block 'javascript-special-operator-type)
(export '%while)
(remprop 'while 'javascript-special-operator)
(remprop 'while 'javascript-special-operator-type)
(export '%do-while)
(remprop 'do-while 'javascript-special-operator)
(remprop 'do-while 'javascript-special-operator-type)
(export '%progn)
(remprop 'progn 'javascript-special-operator)
(remprop 'progn 'javascript-special-operator-type)
(export '%prog)
(remprop 'prog 'javascript-special-operator)
(remprop 'prog 'javascript-special-operator-type)
;; (export '%if)
;; (remprop 'if 'javascript-special-operator)
;; (remprop 'if 'javascript-special-operator-type)
;; (export '%return)
;; (remprop 'return 'javascript-special-operator)
;; (remprop 'return 'javascript-special-operator-type)
;; (export '%block)
;; (remprop 'block 'javascript-special-operator)
;; (remprop 'block 'javascript-special-operator-type)
;; (export '%while)
;; (remprop 'while 'javascript-special-operator)
;; (remprop 'while 'javascript-special-operator-type)
;; (export '%do-while)
;; (remprop 'do-while 'javascript-special-operator)
;; (remprop 'do-while 'javascript-special-operator-type)
;; (export '%progn)
;; (remprop 'progn 'javascript-special-operator)
;; (remprop 'progn 'javascript-special-operator-type)
;; (export '%prog)
;; (remprop 'prog 'javascript-special-operator)
;; (remprop 'prog 'javascript-special-operator-type)
;; (with-foo-output (*standard-output*)
;; (process-js '(= (document.getElementById "repl" ~ innerHTML) "hello")))
......
......@@ -237,7 +237,8 @@ parameter to eat up the macro name."
`(,@front ,namevar ,@back)))
(defun self-evaluating-p (form)
(cond ((atom form) (if (symbolp form) (keywordp form) t))
(cond ((null form) t)
((atom form) (if (symbolp form) (keywordp form) t))
(t (eql (car form) 'quote))))
(defun sexp->ops (language body environment)
......
......@@ -207,11 +207,18 @@
(error "Bad op when not pretty-printing: ~a" op)))
(defmethod op->code ((op (eql :embed-value)) &rest operands)
(let ((value (car operands)))
(and (or value *print-nil*)
(if *pretty*
`(raw-string *text-pretty-printer* (princ-to-string ,value) t)
`(write-sequence ,value *text-output*)))))
(let ((value (gensym)))
`(let ((,value ,(first operands)))
(and (or ,value *print-nil*)
(if *pretty*
(raw-string *text-pretty-printer* (princ-to-string ,value) t)
(write-sequence value *text-output*))))))
(defmethod op->code ((op (eql :embed-value)) &rest operands)
`(let ((value ,(first operands)))
(if *pretty*
(raw-string *text-pretty-printer* value t)
(write-sequence value *text-output*))))
(defmethod op->code ((op (eql :embed-code)) &rest operands)
(let ((value (gensym)))
......
(in-package :wisp-mvc)
;;;; urlmap.lisp
(def-suite urlmap)
(in-suite urlmap)
(test make-url-handler-regex
(is (eql (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_bar")
nil))
(is (eql (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_mo_bar")
nil))
(is (equal
(^string (multiple-value-list (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_o/momo_bar")))
(^string '("abc_o/momo_bar" #("o" "bar")))))
(is (eql (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21_fe/llaf2213")
nil))
(is (eql (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf_2213")
nil))
(is (eql
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213/")
nil))
(is (equal
(^string (multiple-value-list (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213")))
(^string '("21fe/llaf2213" #("21fe" "llaf2213")))))
)
(test extract-url-fnlist
(is (equal
(^string (extract-url-fnlist "/abc__:d_ef/efg_:h") )
(^string '(("abc_" "d_ef") ("efg" "h")))))
(is (equal
(^string (extract-url-fnlist "/:a/:b"))
(^string '(("" "a") ("" "b")))))
)
(test normalize-url-spec
(is (equal
(^string (normalize-url-spec '("show/class1" :handler (fn () (show (find-class 'class1) (find-class 'class2))))))
(^string '((list "show/class1" :handler
#'(lambda nil
(show (find-class 'class1) (find-class 'class2))))))
))
(is (equal
(^string (normalize-url-spec '("show/:class1/:class2" :handler (fn (a b) (show (find-class a) (find-class b))))))
(^string '((list "show/:class1/:class2" :handler
#'(lambda (a b) (show (find-class a) (find-class b))))))
))
(is (equal
(^string (normalize-url-spec '("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2))))
(^string '((list ":arg1/:arg2" :wethod (symbol-function 'foo))
(list "class1_:arg1/:arg2" :wethod (symbol-function 'foo))
(list ":arg1/class2_:arg2" :wethod (symbol-function 'foo))
(list "class1_:arg1/class2_:arg2" :wethod (symbol-function 'foo))))
))
(is (equal
(^string (normalize-url-spec '("" :class-wethod show
(class1 class2)
(class3 class4))))
(^string '((list "class1/class2" :class-wethod (symbol-function 'show))
(list "class3/class4" :class-wethod (symbol-function 'show))))
))
(is (equal
(^string (normalize-url-spec '("some" :map silly-map)))
(^string '((list "some" :map 'silly-map)))
))
)
(defurlmap foo
("" :map bar))
(defurlmap bar
("" :map qux))
(defurlmap qux
;; signals an error because qux refering to foo causes a circular definition.
("" :map foo))
(defurlmap foo2
;; signals an error because foo3 refers to undefined map
("" :map foo3))
(test urlmap-definitional-errors
(signals wisp-circular-nested-urlmap
(attach-urlmap "/" 'foo))
(signals wisp-undefined-nested-urlmap
(attach-urlmap "/" 'foo2)))
(defclass class1 () ((a :initform 1)
(b :initform 2)))
(defclass class2 () ((c :initform 3)
(d :initform 4)))
(defclass class3 (class1) ((a :initform 30)))
(defclass class4 (class2) ())
(defgeneric foo (a b))
(defmethod foo (a b)
(list 'foo a b))
(defmethod foo ((arg1 class1) arg2)
(list 'foo
(with-slots (a b) arg1
(list (class-name (class-of arg1)) a b))
arg2))
(defmethod foo ((arg1 class1) (arg2 class2))
(list 'foo
(with-slots (a b) arg1
(list (class-name (class-of arg1)) a b))
(with-slots (c d) arg2
(list (class-name (class-of arg2)) c d))))
(defmethod ^wisp-arg ((type (eql (find-class 'class1))) arg)
(make-instance 'class1))
(defmethod ^wisp-arg ((type (eql (find-class 'class2))) arg)
(make-instance 'class2))
(defmethod ^wisp-arg ((type (eql (find-class 'class3))) arg)
(make-instance 'class3))
(defmethod ^wisp-arg ((type (eql (find-class 'class4))) arg)
(make-instance 'class4))
(defurlmap wisp
("" :class-wethod foo
(class1 class2))
("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2)
(class3 class4))
("wisp2" :map wisp2)
;; ("a" :instance-wethod show (t t))
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp a b)))
)
(defurlmap wisp2
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp2 a b)))
("" :map wisp3)
)
(defurlmap wisp3
; this should not shadow wisp2
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp3 a b)))
("foo2/:arg1/:arg2" :handler (fn (a b) (list 'wisp3 a b)))
)
(attach-urlmap "/wisp" 'wisp)
;; (get-effective-urls 'wisp)
(test match-url-dispatch-for-url
(signals wisp-no-dispatch-for-url
(match-url-dispatch "abc_21fe/momo_llaf2213/boo" (get-urlmap 'wisp)))
(is (equal
(^string (match-url-dispatch "abc21fe/momollaf2213" (get-urlmap 'wisp)))
(^string '(foo "abc21fe" "momollaf2213"))
))
(is (equal
(^string (match-url-dispatch "class1_abc21fe/momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class1 1 2) "momollaf2213"))
))
(is (equal
(^string (match-url-dispatch "class1_abc21fe/class2_momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class1 1 2) (class2 3 4)))
))
(is (equal
(^string (match-url-dispatch "class3_abc21fe/class4_momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class3 30 2) (class4 3 4)))
))
(is (equal
(^string (match-url-dispatch "foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp "abc" "def"))
))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
))
(is (equal
(^string (match-url-dispatch "wisp2/foo2/abc/def" (get-urlmap 'wisp)))
(^string '(wisp3 "abc" "def"))
))
)
(run! 'urlmap)
;; (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)))))
(in-package :wisp-mvc)
(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 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))
(defun save-wisp-continuation (k-id k)
(setf (gethash k-id *wisp-continuations*) k))
(defun get-wisp-continuation (k-id)