Commit 5992fb5a authored by hayeah via gmail com's avatar hayeah via gmail com

Preliminary work on lisplet

darcs-hash:dbbc6fddc3c90e93e6ee13b66fd375c9833e4eb9
parent 39047c3e
(defpackage :wisp-util
(:use :cl :cl-ppcre :cl-interpol :arnesi :kmrcl) ; :it.bese.fiveam)
(:use :cl :unify :cl-ppcre :cl-interpol :arnesi :kmrcl) ; :it.bese.fiveam)
(:shadowing-import-from :arnesi
:copy-file :random-string
:quit
......@@ -8,10 +8,17 @@
:it :awhen :aand :acond :aif :acond2)
;;(:import-from :arnesi :no-call/cc)
(:shadowing-import-from :cl-ppcre :quote-meta-chars)
(:shadowing-import-from :unify
:match-case
:match)
#+(or)
(:shadowing-import-from :kmrcl
:it :awhen :aand :acond :aif :awhen2 :aif2 :acond2)
(:export
:maptree
:def-with-mode
:with
:with-gensym
:intersection-in-order
:split-by-separators
:^string
......@@ -146,7 +153,11 @@
#:defmethod/cc
#:fmakun-cc
#:*debug-evaluate/cc*
#:*trace-cc*
#:*trace-cc*
;; unification
:unify
:match
:match-case
))
......
......@@ -149,6 +149,18 @@
when rest do (raw-string processor ", "))
(raw-string processor ")"))
;; (defmacro deflang ((lang action method) args body))
;; (deflang (js processor method-call) (method-name object arguments)
;; (rec object :exp)
;; (raw ".")
;; (rec method-name :exp)
;; (raw "(")
;; (loop for (arg . rest) on arguments do
;; (rec arg :exp)
;; when rest do (raw ", "))
;; (raw ")"))
(defun process-function-call (language processor environment name arguments)
(let ((function-expression-statement-p
(and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
......
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Sorry, this is a mess.
;; I am using this more as a sandbox.
;;
(in-package :wisp-mvc)
;; (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)
;; (defwethod wisp-k-handler ()
;; (let ((k-id (param :k-id)))
;; (call-form-handler k-id)))
(defurlmap wisp-sys
("form-k/:k-id" :handler call-form-k)
("test" :package :wisp-mvc))
(attach-urlmap "wisp-sys" 'wisp-sys)
(get-effective-urls 'wisp-sys)
(match-url-dispatch "/test/foo" (get-urlmap 'wisp-sys))
(deform foo-form (arg1 arg2)
(some-object some-string some-text some-number) ;; defines the returned values.
;; return the this form to the continuation.
(list some-object some-string some-text some-number arg1 arg2)
;; wrapped in :wisp-form
(:div "package: " *package*)
(:div (list arg1 arg2))
(:input :name some-object :id 'some-object) (:br)
(:input :name some-string) (:br)
(:textarea :name some-text :id 'some-text) (:br)
(:input :name some-number)
(:input :type 'submit :value 'submit))
(defwethod foo ()
(let ((answer (read-form 'foo-form 3 4)))
(render-html (:html (:div "hurray")
(:div answer)
(:div (show-request))))))
(defun show-request ()
(html *parameters*
(:br)
*package*
(type-of (caar *parameters*))
(param '(foo-form some-object))
(:br)
*request*
*k-id*))
(foo)
(call-form-k "5")
;; (it.bese.arnesi::evaluate-arguments-then-apply
;; #<Closure (:internal (method it.bese.arnesi::evaluate/cc #) 4) @ #x72611102>
;; nil
;; (300)
;; ((:let #:g4714 . 300)
;; (:let #:g4711 . #1=(system:with-timeout . t))
;; (:let #:g4713 system:with-timeout)
;; (:let #:g4669 . t)
;; (:let #:g4667 . 300)
;; (:let #:g4668)
;; (:let #:g4666 . #<net.aserve:computed-entity @ #x7206ff42>)
;; (:let #:g4665 . #<net.aserve:http-request @ #x7257d1da>) .
;; #2=((:let wisp-mvc::answer
;; (wisp-mvc::some-object wisp-mvc::foo-form)
;; (wisp-mvc::some-string wisp-mvc::foo-form)
;; (wisp-mvc::some-text wisp-mvc::foo-form)
;; (wisp-mvc::some-number wisp-mvc::foo-form)
;; 3 4)
;; (:block wisp-mvc::foo it.bese.arnesi::toplevel-k)))
;; ((:catch #1# . #3=(it.bese.arnesi::k-for-evaluate-arguments-then-apply #<Closure # @ #x7260007a> nil nil #2# nil))
;; (:catch net.aserve:with-http-response . #3#)))
(with-foo-output)
(defwethod foo ()
(let* ((foo 10)
(answer (read-form :template (:html (:div this-form))
'foo-form 3 4)))
(print answer)
(print "hurray")))
(foo)
(setf *debug-evaluate/cc* :full)
(setf *debug-evaluate/cc* nil)
(setf *trace-cc* nil)
(deform foo-form (arg1 arg2)
(some-object some-string some-text some-number) ;; defines the returned values.
;; return the this form to the continuation.
(list some-object some-string some-text some-number arg1 arg2)
;; wrapped in :wisp-form
(:div (list arg1 arg2))
(:input :name some-object :id 'some-object)
(:input :name some-string)
(:textarea :name some-text :id 'some-text)
(:input some-number))
(defconthod foo ()
(let ((answer (read-form :template (:html (:div this-form))
'foo-form 3 4)))
(print answer)
(print "hurray")))
(defconthod foo ()
(let ((answer (read-form 'foo-form 3 4)))
(print answer)
(print "hurray")))
(foo)
(maphash (fn (k v) (print (list k v)))
*wisp-read-form-templates*)
(defparameter closure nil)
(defparameter *foo* 100)
(defun bar ()
*foo*)
(with-call/cc
(let ((*foo* 200))
(declare (special *foo*))
(setf closure #'(lambda ()
(let ((blah *foo*))
(bar)))))
(with-call/cc (funcall closure))
(defparameter closure nil)
(defparameter foo 100)
(with-call/cc
(let ((foo 200)
(bar 300))
(setq closure (lambda () (list foo bar)))
foo))
(let ((foo 200))
(with-call/cc
(setq closure (lambda () foo))))
(let ((bar 200))
(with-call/cc
(setq closure (lambda () bar))))
(unwalk-form
(walk-form
'(macrolet ((a () '(list a b c)))
(a))))
(slot-value (walk-form
'(lambda () (macrolet ((a () '(list a b c)))
(a))))
'arnesi::source)
(subtypep (type-of (walk-form
'(lambda () (macrolet ((a () '(list a b c)))
(a)))))
(find-class 'arnesi::form))
(with-call/cc (funcall closure))
(boundp 'foo)
(boundp 'bar)
(makunbound 'bar)
(let ((bar 10))
(symbol-value 'bar))
(let ((bar 10))
(boundp 'bar))
#x7239d83a>)).
Applying cc closure (lambda nil foo) to nil
Evaluating foo.
Evaluating: #<it.bese.arnesi:local-variable-reference foo @ #x723ab1ca>
Lex Env: nil
Dyn Env: nil
K: (it.bese.arnesi::toplevel-k)
#x7260b252>)).
Applying cc closure (lambda nil foo) to nil
Evaluating foo.
Evaluating: #<it.bese.arnesi:free-variable-reference foo @ #x725f4daa>
Lex Env: nil
Dyn Env: nil
K: (it.bese.arnesi::toplevel-k)
Got 100
; Lexical LET - insures lexical bindings (more or less)
(defmacro llet (bindings &body body)
(let* ( (vars (mapcar 'first bindings))
(vals (mapcar 'second bindings))
(gensyms (mapcar (lambda (v) (gensym (symbol-name (first v)))) bindings)) )
`(let ,(mapcar 'list gensyms vals)
(symbol-macrolet ,(mapcar 'list vars gensyms)
,@body))))
(funcall (gethash "(foo foo-form 28)" *wisp-form-handlers*))
(defconthod order ()
(let ((order (read-form 'order-form)))
(print order)
(if ((and (verify-order order)
(read-form 'confirm-order order)))
(render 'show-invoice order))))
(funcall (handler-fn (get-wisp-form 'foo-form)) "(foo foo-form 16)" 2 3)
(funcall (html-fn (get-wisp-form 'foo-form)) "silly-url" 1 2)
(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 :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)))
:template `(:some-template ;; even fancier templating.
:form ,this-form ;;anaphoric reference to the form to be rendred.
:body (:some-other-template
:body (render-view 'some-silly-view)))
:template `(:template 'some-template
:form ,this-form ;;anaphoric reference to the form to be rendred.
:body (:template 'some-other-template
:body (render-view 'some-silly-view)))
:template (:template :some-template
:form this-form ;;anaphoric reference to the form to be rendred.
:body (:template :some-other-template
:body (render-view 'some-silly-view)))
'some-form 'foo-object-class #'bar-validator
: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))))
;; I want a generic way to define dsl's
;; Arbitrary number of environments.
;; Before and after processing. So I can, for example, see the free
;; variables in subforms, then decide what to do for the top form.
;; Works from AST. Assume it's in s-exp. Already translated from
;; lexer/parser.
;; object oriented so deriving sub-languages from sub-language is
;; easy.
;; need global environment for def forms.
(defpackage :wisp-lisplet
(:use :wisp-util :cl :prolog))
(in-package :wisp-lisplet)
(defmacro deflang (lang-name parent-langs &rest definition &aux rules)
(with
:dbind
(env atoms rules) (cdr (split-by-separators definition '(:env :atoms :rules)))
(atom-defs atom-match-fns) (make-atom-definitions (cdr atoms))
(rule-defs rule-match-fns) (make-rule-definitions (cdr rules))
:do `(progn ,atom-defs
(register-atom-fns ',lang-name ,(cons 'list atom-match-fns))
,rule-defs
(register-rule-fns ',lang-name ,(cons 'list rule-match-fns)))))
;; (defun make-lang-definition (defs rule-making-fn)
;; (let ((types (delete-duplicates (mapcar #'car defs)))
;; parse-fns)
;; (list
;; `(progn ,@(mapcar (fn (type)
;; `(defclass ,type ()))
;; types)
;; ,@(mapcar (fn (def)
;; (let ((type (first def))
;; (matcher (second def))
;; (class-name (third def))
;; (class-slots (fourth def)))
;; (push (funcall rule-making-fn matcher) parse-fns)
;; `(defclass ,class-name (,type)
;; ,(make-class-slots class-slots))))
;; defs))
;; (nreverse parse-fns))))
;; (defun make-atom-definitions (atom-defs)
;; (make-lang-definition atom-defs #'identity))
(defun make-atom-definitions (atom-defs)
(let ((atom-types (delete-duplicates (mapcar #'car atom-defs)))
match-fns)
(list
`(progn ,@(mapcar (fn (atom-type)
`(defclass ,atom-type ()))
atom-types)
,@(mapcar (fn (def)
(let ((atom-type (first def))
(test-fn (second def))
(atom-class-name (third def))
(atom-class-slots (fourth def)))
(push test-fn match-fns)
`(defclass ,atom-class-name (,atom-type)
,(make-class-slots atom-class-slots))))
atom-defs))
(nreverse match-fns))))
(defun make-class-slots (slots)
(loop for slot in slots
collect (list slot :initarg (^keyword slot) :accessor slot)))
(defun make-rule-definitions (rule-defs)
(let ((types (delete-duplicates (mapcar #'car rule-defs)))
match-fns)
(list
`(progn ,@(mapcar (fn (type)
`(defclass ,type ()))