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

Started working on MVC.

darcs-hash:eea8b98b8531c5996c201d162262d407043ca373
parent ab4cf260
......@@ -6,7 +6,8 @@
;;; 5.3 Universal selector
;; * p
(* p)
(* p)
;;; 5.5 Descendant selectors
;; ul ol ul em {color: gray;}
......@@ -38,30 +39,30 @@
;; Match when the element's "att" attribute value is a hyphen-separated list of "words", beginning with "val". The match always starts at the beginning of the attribute value. This is primarily intended to allow language subcode matches (e.g., the "lang" attribute in HTML) as described in RFC 1766 ([RFC1766]).
;; *[LANG|="en"] { color : red }
(* @ (- LANG "en")) ;; hyphen separated
(ref * (- LANG "en")) ;; hyphen separated
;; A[rel~="copyright"]
(a @ (_ rel "copyright")) ;;space separated
(ref a (_ rel "copyright")) ;;space separated
;; foo[bar][jar~="mar"][dada|="gaga"][qux="deluxe"]
(foo @ bar (_ jar "mar") (- dada "gaga") (dada "gaga"))
(ref foo bar (_ jar "mar") (- dada "gaga") (dada "gaga"))
;;;; 5.8.3 Class selectors
;; .pastoral.marine
(~ pastoral marine)
.pastoral.marine
;; P.pastoral.marine { color: green }
(p ~ pastoral marine)
p.pastoral.marine
;; div p.pastoral.marine { color: green }
(div (p ~ pastoral marine))
(div p.pastoral.marine)
;; td.sidebar a:link {color: white;}
((td ~ sidebar) (a :link))
(td.sidebar a:link:hover)
;; * .warning
(* ~ warning)
(* .warning)
;; Note. CSS gives so much power to the "class" attribute, that authors could conceivably design their own "document language" based on elements with almost no associated presentation (such as DIV and SPAN in HTML) and assigning style information through the "class" attribute. Authors should avoid this practice since the structural elements of a document language often have recognized and accepted meanings and author-defined classes may not.
;; ;; What? Isn't this the whole idea? No presentation information in the HTML structure.
......@@ -124,9 +125,17 @@
;; ;; Can there be selectors like these??
;; a.b.c[foo][bar][qux]
(a ~ b c @ foo bar qux)
(:ref a.b.c foo bar qux)
;; c[foo][bar][qux].b.a
(c @ foo bar qux ~ b a)
(:dot (:ref c foo bar qux)
b a)
;; .c[foo][bar][qux].b.a
(:dot (:ref .c foo bar qux)
b a)
;; ;; forget it, require ~ before @.
......@@ -134,29 +143,34 @@ div.c.d > span.foo span + a:link:visted
div.c.d:hover > span.foo span + a:link:visted
(> (div ~ c d)
(+ ((span ~ foo) span)
(div :hover)))
(> div.c.d
(+ (span.foo span) div:hover))
div.c.d > span.foo span + div:hover
(+ (> ((span ~ foo) span)
(div :hover))
(div ~ c d))
(+ (> (span.foo span)
div:hover)
div.c.d)
span.foo span > div:hover + div.c.d
(+ (div ~ c d)
(> ((span ~ foo) span)
(div :hover)))
(+ div.c.d
(> (span.foo span) div:hover))
div.c.d + span.foo span > div:hover
(+ (div ~ c d $ id1)
(> ((span ~ foo $ id2) span)
(div $ id3 :hover)))
(+ div.c.d$id1
(> (span.foo$id2 span) div$id3:hover))
div.c.d#id1 + span.foo#id2 span > div#id3:hover
(:sib div.c.d$id1
(:kid (span.foo$id2 span) div$id3:hover))
;; I am already being cryptic with :sib and :kid, what's wrong with + and >?
;; ;; It's just a little annoying for them to remind me of mathematical symbols.
;; ;; Plus, they don't really mean anything.
......@@ -137,7 +137,9 @@ Return:
(defun process-non-import-css (processor sexp)
(destructuring-bind (selector &rest attributes) sexp
(freshline processor)
(emit-css-selector processor selector)
(if (selector-group? selector)
(emit-selector-group processor (cdr selector))
(emit-selector processor selector))
(freshline processor)
(raw-string processor "{")
(indent processor)
......@@ -187,11 +189,16 @@ Return:
(values (ldiff selector pseudo-classes) pseudo-classes)
(error "pseudo-classes must be at the end of a selector expression: ~S" selector))))
(defun emit-css-selector (processor selector)
(defun emit-selector (processor selector)
(cond
((atom selector) (raw-string processor (string-downcase (string selector))))
((selector-group? selector) (emit-selector-group processor (cdr selector)))
((selector-descendents? selector) (emit-selector-descendents processor (cdr selector)))
((atom selector) (raw-string processor (string-downcase (string selector))))
((and (consp selector) (member (first selector) '(:and > +)))
;; TODO :or can only be used one. That is, nested or doens't make sense.
(loop with separator = (case (first selector)
(:and " ") (+ " + ") (> " > "))
for (x . rest) on (rest selector)
do (emit-css-selector processor x)
when rest do (raw-string processor separator)))
(t
(multiple-value-bind (selector pseudo-classes)
(extract-pseudo-classes selector)
......@@ -200,7 +207,7 @@ Return:
(when descendents (emit-selector-descendents processor descendents))
(when classes (raw-string processor (format nil "~{.~a~}" (cdr classes))))
(emit-selector-attributes processor (cdr attributes))
;; does id come after attributes or before?
;; does id go after attributes or before?
(when id
(and (> (length id) 2) (error "Only one id is allowed for one selector expression ~S" selector))
(raw-string processor (format nil "#~a" (second id))))
......
......@@ -52,7 +52,7 @@
;; }
;; }).call(this));
(process-ls '(PROGN a b c))
(process-ls '(progn a b c))
;; (function () {
;; A;
;; B;
......@@ -64,7 +64,7 @@
;; A;
;; B;
;; return C;
(process-ls '(LET ((foo bar)) (foo bar)))
(process-ls '(let ((foo bar)) (foo bar)))
;; (function (FOO) {
;; return FOO(BAR);
......@@ -72,7 +72,7 @@
;; (process-ls '(block foo (block foo2 how happy i am (return-from foo 10)) and you are happy too))
(process-ls '(+ 1 (BLOCK boo 1 3 (RETURN-FROM boo 2) 4)))
(process-ls '(+ 1 (block boo 1 3 (return-from boo 2) 4)))
;; ((function (block$BOO) {
;; try {
......@@ -117,24 +117,32 @@
:padding 40))
;; wrong
(css (((do ~ re @ mi) (fa ~ bah) ~ so @ la :ti :do)
(css (((do ~ re @ mi) (fa ~ bah @ dah :boo :foo) ~ so @ la :ti :do)
:padding 40))
(css ((:or foo bar)
:padding 3))
;; error
(css ((:or a b (:or c d))
:padding 3))
(css (((foo ~ do re mi @ ping pong)
(fa ~ so la @ bar (_ jar "mar") (- mama "gaga") (papa "dada")))
(css ((+ (div ~ c d)
(> ((span ~ foo) span)
(div :hover)))
:padding 40))
(css ((:and
(foo ~ do re mi @ ping pong)
(fa ~ so la @ bar (_ jar "mar") (- mama "gaga") (papa "dada")))
(css ((+ (div ~ c d)
(> ((span ~ foo) span)
(div :hover)))
:padding 40))
(css ((+ (div ~ c d $ id1)
(> ((span ~ foo $ id2) span)
(div $ id3 :hover)))
:padding 30))
(css (((foo ~ do re mi @ ping pong)
(fa ~ so la @ bar (_ jar "mar") (- mama "gaga") (papa "dada")))
:padding 40))
(css (body :padding "6pt"))
(css (body :padding 6pt))
......@@ -214,3 +222,9 @@
;; (.result color "#0000ff" padding-top "3pt" margin "0pt")
;; (.output color "#ff00ff" padding-top "3pt" margin "0pt")
;; (.error color "#ff0000" padding-top "3pt" margin "0pt"))
(in-package :com.gigamonkeys.ajax)
(asdf :com.gigamonkeys.ajax)
(start-ajax-server)
\ No newline at end of file
;; What happens if I output half of the page, then decided to transffer control to some other page?
;; ;; As in forward and error report.
(in-package :wisp-mvc)
(unless (wserver-socket *wserver*) (start :port 2002))
(defparameter *defined-wethods* (make-hash-table :test #'equal))
(defmacro defwethod (name (&rest arglist) &body body)
`(progn (defmethod ,name ,arglist ,@body)
(setf (gethash ,(string-invert (symbol-name name))
*defined-wethods*)
(symbol-function ',name))))
(defun find-wethod (function-name)
(gethash function-name *defined-wethods*))
#\,))
(defparameter *wethod-arglist-init-fns* (make-hash-table :test #'equal))
(defun get-wethod-signature (req)
(cons (request-query-value "wethod-name" req)
(delimited-string-to-list (request-query-value "specializers" req)
#\,)))
(defun get-wethod-arguments (req)
(delimited-string-to-list (request-query-value "wethod-args" req)
(defun make-wethod-arglist (specializer-names query-arguments)
(aif (gethash specializer-names *wethod-arglist-init-fns*)
(multiple-value-list (funcall it query-arguments))
(mapcar (fn (class id)
(aif (retrieve class id)
it
(error 'no-wobject-with-id :class class :id id)))
specializer-names query-arguments)))
(defun apply-wethod (req)
(let* ((signature (get-wethod-signature req))
(function-name (car signature))
(specializer-names (cdr signature))
(query-arguments (get-wethod-arguments req)))
(print (symbol-package (^symbol function-name)))
(print *package*)
(apply
;;(^symbol function-name)
;;(intern (string-upcase function-name) (find-package :wisp-mvc))
;; this is pretty obscure. Intern interns to the current package.
;; Because getting the symbol this way is dynamic, what I get depends
;; on the runtime state. That is, the closure behaves differently.
;; So if I am in the wrong package, symbol-function won't find the
;; function to apply
(find-wethod function-name)
(make-wethod-arglist specializer-names query-arguments))))
(defmacro respond-with-html ((req ent) &body body)
`(let ((html-response
(let ((*html-output-stream* (make-string-output-stream)))
(declare (special *html-output-stream*))
(unwind-protect
(handler-case (progn ,@body (get-output-stream-string *html-output-stream*))
(werror (c)
;; bind a fresh output stream
(close *html-output-stream*) (setf *html-output-stream* (make-string-output-stream))
(fmt :> *html-output-stream*
"Unhandled Error Signaled." :%)
(print c *html-output-stream*)
(get-output-stream-string *html-output-stream*)))
(close *html-output-stream*)))))
(with-http-response (,req ,ent)
(with-http-body (,req ,ent)
(let ((out (request-reply-stream req)))
(write-string html-response out))))))
;; The defmethod-like mapper is good when we want something specific. Not so good
;; if I want something general about a class.
;;
;; Maybe all I need is a "class" control?
;; ;; Nah, just keep it simple.
;; ;; Map URL to method signature.
;; ;; /method-name/specializer1/arg1-id/specializer2/arg2-id.../?key1=?;key2=?...
;; (defgeneric find-instances (class request &key :gt :lt :eq)
;; ;; return list of all classes
;; )
(def-control list (standard-class &key (limit 100))
;; url: /list/standard-class/<arg-class>/limit/<arg-limit>
;;find all instances of the class
;;list all the instances
)
;; Straight parm mapping
(def-control show (friend-id foe-id)
(let* ((friend-id (request 'friend-id))
(foe-id (request 'foe-id))
(friend (retrieve 'friend friend-id))
(foe (retrieve 'foe friend-id)))
(display-flame-war friend foe :severity 'bitter)))
;; Class-oriented dispatch
;; ;; Common lisp doesn't have class methods. I need some kind of class oriented dispatcher.
;; Map to: /<class-name>/<method-name>/
(def-class-wethod list ((class wobject-class))
(display-instances (find-instances class)))
;; instance-oriented dispatch
;; ;; When we want only one object.
;; Map to: /<method-name>/<arg-name1>/<arg-val1>/<arg-name1>/<arg-val1>...?key1=val1&key2=val2...
(defwethod-args show (friend foe)
(let ((friend-id (request 'friend-id))
(foe-id (request 'foe-id)))
(call-wethod (retrieve 'friend friend-id)
(retrieve 'foe friend-id))))
(defwethod show ((friend friend) (foe foe))
(display-flame-war friend foe :severity 'bitter))
......@@ -44,8 +44,12 @@
(in-package :wisp.util)
(in-package :wisp-util)
(eval-when (:compile-toplevel :load-toplevel :execute)
(cl-interpol:enable-interpol-syntax)
;;; rkr lambda-list
......@@ -137,6 +141,8 @@
(list '&key keyarg)))
)
;;; fmt macro
;;;; Issues
;; problem: (:<op> ...) and (fmt-<op> ...) don't mix well.
......@@ -194,7 +200,8 @@
(case >
((nil) `(with-output-to-string (*fmt-stream*)
(pprint-logical-block (*fmt-stream* nil) ,body)))
(t `(pprint-logical-block (,> nil) ,body)))))
(t `(let ((*fmt-stream* ,>))
(pprint-logical-block (*fmt-stream* nil) ,body))))))
(defmacro fmt* (&rest fnlist)
......
;; It might be interesting to use Cell for its constraint passing programming style.
#|
How should I deal with inheritance?
It would be nice if I can list a class, and I'll get all the sub classes as well.
Well... I could save the metaclass information. But that's not very helpful.
Or I can list the direct instances then link over the subclasses?
|#
(in-package :wisp-mvc)
(defpclass wisp-object () ())
(defun ^class-name (class-thing)
(etypecase class-thing
;; Not all classes are under standard class
(standard-class (class-name class-thing))
(symbol class-thing)
(string (intern (string-invert class-thing)))))
(defun ^class (class-thing)
(find-class (^class-name class-thing)))
(defun find-class-btree (class)
(let* ((class-name (^class-name class)))
(get-from-root class-name)))
(defun ensure-class-btree (class)
(aif (find-class-btree class)
it
(add-to-root class-name (make-btree))))
(defun find-instances (class)
"Find all instances that belong to the class"
(let* ((class-name (^class-name class))
(class-btree (get-from-root class-name))
(instances nil))
(when class-btree (map-btree (fn (k v) (push v instances)) class-btree))
instances))
(defun find-instances* (class)
"Find all instances that belong to the class and its subclasses"
(let* ((class-name (^class-name class))
(sub-classes (mop:class-direct-subclasses (find-class class-name))))
(append (find-instances class)
(mappend (fn (sub-class) (find-instances* sub-class))
sub-classes))))
;;;; Simple CRUD
;; ;; ;; Elephant takes care of update.
(defmethod create ((object wisp-object) &key force?)
(let* ((class-btree (ensure-class-btree (class-of object)))
(stored-object (get-value (^string (ele::oid object)) class-btree)))
(if (and stored-object (not force?))
(error "Object ~S of class ~S already created" object (class-of object))
(setf (get-value (^string (ele::oid object)) class-btree) object))))
(defmethod retrieve (class oid)
(awhen (find-class-btree (^symbol class)) (get-value oid it)))
(defmethod destroy ((object wisp-object) &key force?)
(let ((class-btree (find-class-btree (class-of object))))
(remove-kv (ele::oid object) class-btree)))
(defun slot-names (class)
(mapcar (fn (slot-def) (mop:slot-definition-name slot-def))
;; class-slots instead of direct slots gives too much information in many cases.
(mop:class-slots (^class class))))
(defun slot-values (class object)
(mapcar (fn (slot-name)
;; TODO: heed the caveat from elephant manual that slot-value might not work properly
(slot-value object slot-name))
(slot-names class)))
(defmethod wisp-object->sexp ((object wisp-object))
(let ((class (class-of object)))
(list (class-name class)
(cons (slot-names class)
(slot-values class object)))))
(defgeneric print-object-content (object))
(defmethod print-object-content (object))
(defmethod print-object-content ((object wisp-object))
(print (wisp-object->sexp object)))
(defpackage :wisp-util (:use :cl :cl-interpol :kmrcl) ; :it.bese.fiveam)
(:export
:^string
:^symbol
;; :until
:fn
:mklst
:cat-syms
:strcat
:symcat ;; renamed cat-syms
:mappend
:group
:mvbind
:mvsetq
:dbind
;;anaphoric macros
:self
:afn
:split-if
:fmt))
(defpackage :wisp-mvc
(:use :wisp-util :cl :elephant :net.aserve :kmrcl)
(:export :find-instances
:find-instances*
:create
:destroy
:retrieve
:print-object-content
;; wethod, wisplay, wobject. Hahaha...
)
(:import-from :elephant defpclass))
\ No newline at end of file
......@@ -388,7 +388,6 @@
(values (nreverse result) max))))
(defun map0-n (fn n)
"map over a generated list of (0 ... n) inclusive"
(mapa-b fn 0 n))
......
(defpackage wispy-lisp-system
(:use :cl :asdf))
(in-package :wispy-lisp-system)
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package 'cl-interpol)
(asdf:operate 'asdf:load-op 'cl-interpol))
(unless (find-package 'elephant)
(asdf:operate 'asdf:load-op 'elephant))
(unless (find-package 'aserve)
(require :aserve))
(cl-interpol::enable-interpol-syntax)
(unless *print-right-margin* (setf *print-right-margin* 70 )))
(defsystem :wispylisp
:description "Wispy Lisp: a web-framework."
:version "0.001"
:author "Howard Yeh <hayeah at gmail dot com>"
:licence "BSD"
:components ((:file "packages")
(:file "util")
(:file "fmt")
(:file "model")
(:file "view"))
:serial t)
\ No newline at end of file
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