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

Modified css.lisp to allow *very* complicated selectors.

In the process generalized split-by-separators (was split-by-tests).
The big ugly loop is even loopier now.

darcs-hash:acacf9ac5c9eb24228a0edd2a63005cabb7d980c
parent 3eada829
;;;; 5.2.1 Grouping
;; H1, H2, H3 { font-family: sans-serif }
(:or h1 h2 h3)
;;; 5.3 Universal selector
;; * p
(* p)
;;; 5.5 Descendant selectors
;; ul ol ul em {color: gray;}
(ul ol ul em)
;;; 5.6 Child selectors
;; h1 > strong {color: red;} ;; children
(h1 > strong)
;; DIV OL>LI P
(div ol > li p)
;;; 5.7 Adjacent sibling selectors
;; h1 + p {margin-top: 0;} ;; adjacent
(h1 + p)
;;; 5.8 Attribute Selector
;;;; 5.8.1 Matching attributes and attribute values
;; [att]
;; Match when the element sets the "att" attribute, whatever the value of the attribute.
;; [att=val]
;; Match when the element's "att" attribute value is exactly "val".
;; [att~=val]
;; Match when the element's "att" attribute value is a space-separated list of "words", one of which is exactly "val". If this selector is used, the words in the value must not contain spaces (since they are separated by spaces).
;; [att|=val]
;; 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
;; A[rel~="copyright"]
(a @ (_ rel "copyright")) ;;space separated
;; foo[bar][jar~="mar"][dada|="gaga"][qux="deluxe"]
(foo @ bar (_ jar "mar") (- dada "gaga") (dada "gaga"))
;;;; 5.8.3 Class selectors
;; .pastoral.marine
(~ pastoral marine)
;; P.pastoral.marine { color: green }
(p ~ pastoral marine)
;; div p.pastoral.marine { color: green }
(div (p ~ pastoral marine))
;; td.sidebar a:link {color: white;}
((td ~ sidebar) (a :link))
;; * .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.
;;; 5.9 ID selectors
;; H1#chapter1 { text-align: center }
(h1 $ chapter1)
;; rather unfortunate $ happens to sit beside #
;; ;; prototype chose $ for get-element-by-id Perhaps for the same reason?
;;; 5.11 Pseudo-classes
:first-child
:link
:visited
:hover
:active
:focus
:first-line
:first-letter
:before
:after
;;;; Combination
;; Should I allow different kinds of selectors in the same consp?
(a b ~ moo mah :link :hover)
;; or
((a b ~ moo mah) :link :hover)
;; a b.moo.mah ??
(a (b ~ moo mah) :link :hover) ;; illegal. Pseudo-classes must follow one single selector
(a ((b ~ moo mah) :link :hover))
;; a b.moo.mah:link:hover
;; Maybe the best way to deal with pseudo classes is to move them within cascading.
;; ;; Pseudo classes always at the end of selector. No exceptions. Else doesn't make sense.
;;;; Parsing Complex selectors
;; Import
;; Group
;; ;; Pseudo-classes (postfix)
;; ;; ;; keyword
;; ;; Selectors
;; ;; ;; ID (postfix?)
;; ;; ;; ;; $
;; ;; ;; Structure (prefix?)
;; ;; ;; ;; > +
;; ;; ;; Attribute (infix?)
;; ;; ;; ;; ~ @
;; postfix is appropriate when nothing else can follow
;; prefix is appropriate to denote structural relationship
;; infix is appropriate when there can be arbitrarily many operands on either sides of the operator.
;; ;; Can there be selectors like these??
;; a.b.c[foo][bar][qux]
(a ~ b c @ foo bar qux)
;; c[foo][bar][qux].b.a
(c @ foo bar qux ~ b a)
;; ;; forget it, require ~ before @.
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
(+ (> ((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 $ id1)
(> ((span ~ foo $ id2) span)
(div $ id3 :hover)))
div.c.d#id1 + span.foo#id2 span > div#id3:hover
;; TODO: Make cascading more structurally explicit
(defun split-by-separators (lst test-lst &key ((:test default-test) #'eql))
"The provided list of tests are used as separators to break a list into list of alists.
Each alist is headed by the separator.
The if the test if an not a procedure, it is compared to each element of the list with eql as default.
-
The list to be splitted must satisfy 2 conditions:
1) The separators must occur in sequential order.
2) Separators must not occur twice in the same list.
-
Some separators may be omitted from the list, in which case, nil account for them in the resulting list.
-
Return:
(<args-before-first-separator> [[<separator> <args-between-this-and-next-separator>) | nil]]*) "
(unless lst (return-from split-by-separators (make-list (1+ (length test-lst)))))
(flet ((do-test (test obj)
(if (functionp test)
(funcall test obj)
(funcall default-test test obj))))
(loop with todo-tests = test-lst
with done-tests = nil
with section = nil ; What I really want is use collect instead, but see next comment
for objs on lst
for obj = (car objs)
for (attempted-tests separator separator?) =
(loop for test in todo-tests
collect test into attempted-tests
thereis (and (do-test test obj)
(setq done-tests (append attempted-tests done-tests))
(list attempted-tests obj t))
finally (list attempted-tests nil nil))
if separator?
nconc (append (list (nreverse section))
(make-list (1- (length attempted-tests)))) into sections
and do (setq section (list obj) ; I need to set section nil here, but if using collect would reset it back.
todo-tests (cdr (member separator todo-tests)))
and do (unless (cdr objs) (return (nconc sections (list section) (make-list (length todo-tests)))))
else do
(cond ((loop for test in done-tests thereis (do-test test obj))
(error "repeated separator ~S found. With tests ~S on list ~S" obj test-lst lst))
;; append unfinished tests and attempted tests
;; ;; actually, at this point, all unfinished tests are found in attempted tests
((null (cdr objs)) (return (progn (nconc sections
(list (nreverse (push obj section)))
(make-list (length todo-tests))))))
(t (push obj section)))
end)))
;; (equal (split-by-tests '(0 a 1 2 c 3 4 d 40 4) '(a b c d e f))
;; '((0) (a 1 2) nil (c 3 4) (d 40 4) nil nil))
;; (equal (split-by-tests '(a b f) '(a b c d e f))
;; '(nil (a) (b) nil nil nil (f)))
;; (equal (split-by-tests '() '(a b c d e f))
;; '(nil nil nil nil nil nil nil))
;; (equal (split-by-tests '(1 2 3 4) '())
;; '((1 2 3 4)))
;;
;; Copyright (c) 2005, Gigamonkeys Consulting All rights reserved.
;;
......@@ -43,16 +103,20 @@
(when (eql (car form) :import) :import))
(defmethod sexp-form-p ((language css) form)
(or (self-evaluating-p form) (consp form)))
(or (css-atom? form) (consp form)))
(defmethod embeddable-value-form ((language css) form)
`(string-downcase (princ-to-string ,form)))
`(string-downcase (princ-to-string ,form))))
(defun css-atom? (form)
;; what about nil??
(atom form))
(defmethod process-sexp ((language css) processor form environment)
(declare (ignore environment))
(declare (ignore environment))
(cond
((self-evaluating-p form)
(raw-string processor (string-downcase (princ-to-string form)) t))
((css-atom? form)
(raw-string processor (princ-to-string form) t))
((eql (first form) :import)
(emit-css-import processor form))
(t
......@@ -89,25 +153,60 @@
(raw-string processor "}")
(freshline processor)))
(defun selector-group? (selector)
(eql (car selector) :or))
(defun selector-descendents? (selector)
(eql (car selector) :and))
(defun emit-selector-group (processor selectors)
(loop with separator = ", "
for (selector . rest) on selectors
do (emit-css-selector processor selector)
when rest do (raw-string processor separator)))
(defun emit-selector-descendents (processor descendents)
(loop with separator = " "
for (descendent . rest) on descendents
do (emit-css-selector processor descendent)
when rest do (raw-string processor separator)))
(defun emit-selector-attributes (processor attributes)
(loop for (attribute . rest) on attributes
do (if (atom attribute)
(raw-string processor (format nil "[~A]" attribute))
(case (car attribute)
(_ (raw-string processor (format nil "[~A~~=\"~A\"]" (second attribute) (third attribute))))
(- (raw-string processor (format nil "[~A|=\"~A\"]" (second attribute) (third attribute))))
(t (raw-string processor (format nil "[~A=\"~A\"]" (first attribute) (second attribute))))))))
(defun extract-pseudo-classes (selector)
(let ((pseudo-classes (member-if #'keywordp selector)))
(if (every #'keywordp pseudo-classes)
(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)
(cond
((atom selector)
(raw-string processor (string-downcase (string selector))))
((and (consp selector) (member (first selector) '(or :or and :and adjacent :adjacent > :>)))
(loop with separator = (case (first selector) ((or :or) ", ") ((and :and) " ") ((adjacent :adjacent) " + ") ((> :>) " > "))
for (x . rest) on (rest selector)
do (emit-css-selector processor x)
when rest do (raw-string processor separator)))
((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)))
(t
(multiple-value-bind (tag class pseudo-class id) (parse-selector selector)
(when tag
(raw-string processor (string tag)))
(when class
(raw-string processor (format nil ".~(~a~)" class)))
(when pseudo-class
(raw-string processor (format nil ":~(~a~)" pseudo-class)))
(when id
(raw-string processor (format nil "#~(~a~)" id)))))))
(multiple-value-bind (selector pseudo-classes)
(extract-pseudo-classes selector)
(destructuring-bind (descendents classes attributes id)
(split-by-separators selector '(~ @ $))
(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?
(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))))
(when pseudo-classes (raw-string processor (format nil "~{:~a~}" pseudo-classes))))))))
(defun parse-selector (selector)
(if (member (first selector) '(:class :pseudo-class :id))
......
......@@ -54,57 +54,64 @@
;;;; Utility for Javascript message-passing parser .
(defun split-by-tests (lst test-lst &key ((:test default-test) #'eql))
(defun split-by-separators (lst test-lst &key ((:test default-test) #'eql))
;; This is super ugly. I don't even know which language this function is written in.
"The provided list of tests are used as separators to break a list into list of alists.
Each alist is headed by the separator.
The if the test if an not a procedure, it is compared to each element of the list with eql as default.
-
The list to be splitted must satisfy 2 conditions:
1) The separators must occur in sequential order.
2) Separators must not occur twice in the same list.
-
Some separators may be omitted from the list.
Some separators may be omitted from the list, in which case, nil account for them in the resulting list.
-
Return:
(<args-before-first-separator> (<separator> <args-between-this-and-next-separator>)*) "
(flet ((do-test (test msg)
(<args-before-first-separator> [[<separator> <args-between-this-and-next-separator>) | nil]]*) "
(unless lst (return-from split-by-separators (make-list (1+ (length test-lst)))))
(flet ((do-test (test obj)
(if (functionp test)
(funcall test msg)
(funcall default-test test msg))))
(loop with tests = test-lst
(funcall test obj)
(funcall default-test test obj))))
(loop with todo-tests = test-lst
with done-tests = nil
with section = nil ; What I really want is use collect instead, but see next comment
for msgs on lst
for msg = (car msgs)
for is-separator? = (loop for test in tests
collect test into done-tests2
thereis (and (do-test test msg)
(setq done-tests (append done-tests2 done-tests)) done-tests2))
if is-separator?
collect (nreverse section) into sections
and do (setq section (list msg) ; I need to set section nil here, but if using collect would reset it back.
tests (cdr tests))
else
if (loop for test in done-tests thereis (do-test test msg))
do (error "repeated separator ~S found. With tests ~S on list ~S" msg test-lst lst)
else do (push msg section)
end
end
finally (return (nconc sections (list (nreverse section)))))))
(defun parse-js-form (js-form)
"Parse javascript form of the form (<js-form>* [~ <js-form>*] [@ <js-form>*])
Where forms before ~ are object path.
Between ~ and @ are arguments to method application.
After @ are array references.
-
Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
(let* ((separators '(~ @))
(broken-form (split-by-tests js-form '(~ @))))
(cons (car broken-form)
(mapcar #'(lambda (separator)(assoc separator broken-form))
separators))))
for objs on lst
for obj = (car objs)
for (attempted-tests separator separator?) =
(loop for test in todo-tests
collect test into attempted-tests
thereis (and (do-test test obj)
(setq done-tests (append attempted-tests done-tests))
(list attempted-tests obj t))
finally (list attempted-tests nil nil))
if separator?
nconc (append (list (nreverse section))
(make-list (1- (length attempted-tests)))) into sections
and do (setq section (list obj) ; I need to set section nil here, but if using collect would reset it back.
todo-tests (cdr (member separator todo-tests)))
;; The special case where the separator is the last object in the list
and do (unless (cdr objs) (return (nconc sections (list section) (make-list (length todo-tests)))))
else do
(cond ((loop for test in done-tests thereis (do-test test obj))
(error "repeated separator ~S found. With tests ~S on list ~S" obj test-lst lst))
;; append unfinished tests and attempted tests
((null (cdr objs)) (return (progn (nconc sections
(list (nreverse (push obj section)))
(make-list (length todo-tests))))))
(t (push obj section)))
end)))
;; (equal (split-by-tests '(0 a 1 2 c 3 4 d 40 4) '(a b c d e f))
;; '((0) (a 1 2) nil (c 3 4) (d 40 4) nil nil))
;; (equal (split-by-tests '(a b f) '(a b c d e f))
;; '(nil (a) (b) nil nil nil (f)))
;; (equal (split-by-tests '() '(a b c d e f))
;; '(nil nil nil nil nil nil nil))
;; (equal (split-by-tests '(1 2 3 4) '())
;; '((1 2 3 4)))
(defun string-invert (str)
"Invert case of a string"
......@@ -149,7 +156,7 @@ Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
;; ;; ;; possibly make function a special form s.t. ~ is not required?
(if (consp form)
;; Need to deal with anonymous function call using process-function-call
(destructuring-bind (objects args arefs) (parse-js-form form)
(destructuring-bind (objects args arefs) (split-by-separators form '(~ @))
(unless objects (error "illegal javascript form ~S. No object path." form))
(process-object-path language processor environment objects)
(when args (process-method-call language processor environment (cdr args)))
......
(foo ~)
foo();
# Special Case
(foo)
foo();
foo
foo
(foo @)
foo[];
(foo @ a)
foo[a];
(foo bar ~)
foo.bar();
(foo ~ a b)
foo(a,b);
(foo bar ~ a b @ c d)
foo.bar(a,b)[c][d];
((foo bar ~ a b @ c d) ~ e f)
foo.bar(a,b)[c][d](e,f);
\ No newline at end of file
(in-package :com.gigamonkeys.foo.javascript)
(process-js '(foo bar BazBaf ~ ab cd @ la boo))
(process-js 'foo)
(process-js '(%if 1 2 3))
(process-js '(switch 1 (2 3) (4 5)))
(process-js '(switch 1 (2 3) (4 5)))
(process-js '(%return ((function () 3 4 5) ~)))
(process-js '((function () 3) ~))
(process-js '(%return ((fn () 3 4 5) ~)))
(process-js '((fn () 3) ~))
(process-js '(%prog foo 1 2))
(in-package :com.gigamonkeys.foo.lispscript)
(process-ls '(scope ((a b) (c d)) foo 1 2))
(process-ls '(return-last 1 2 a))
(process-ls '(let ((a 10)) 1 2 a))
(process-ls '(dolist (a b) (return-from nil 3)))
(process-ls '(block foo 1 2))
(process-ls '(%prog foo 1 2))
(process-ls '(progn 1 2 3 4))
(process-ls '(block foo 1 (block foo 2 (return-from foo 3)) (return-from foo 4)))
(process-ls '(defun joe (boo) boo))
(process-ls '(defun joe (boo) boo))
(process-ls '(+ 0 (if 1 2 3)))
(process-ls '(xml (:hello jerk face)))
(process-ls '(xml (:b jerk face)))
;; (process-ls '(+ 10 (IF 1 2 3)))
;; (10 + (function () {
;; if (1) {
;; return 2;
;; } else {
;; return 3;
;; }
;; }).call(this));
(process-ls '(PROGN a b c))
;; (function () {
;; A;
;; B;
;; return C;
;; }).call(this);
(process-ls '(return-last a b c))
;; A;
;; B;
;; return C;
(process-ls '(LET ((foo bar)) (foo bar)))
;; (function (FOO) {
;; return FOO(BAR);
;; }).call(this, BAR);
;; (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)))
;; ((function (block$BOO) {
;; try {
;; 1;
;; 3;
;; block$BOO.value = 2;
;; throw block$BOO;
;; } catch (g$1) {
;; if ((g$1 === block$BOO)) return block$BOO.value; else throw g$1;
;; }
;; }))({ value : undefined });
(in-package :com.gigamonkeys.foo.css)
;; foo[bar][jar~="mar"][dada|="gaga"][qux="deluxe"]
(css ((do ~ re @ mi)
:padding 40))
;; as a matter of curiosity, this is equivalent to the above
(css ((((((((((((do ~ re @ mi)))))))))))
:padding 40))
;; ;; when in this form, the last selector expression in the list of descendents must be an atom.
(css (((do ~ re @ mi) fa ~ so @ la :ti :do)
:padding 40))
;; preferred form
(css (((do ~ re @ mi) (fa ~ so @ la :ti :do))
:padding 40))
;; even better
;; ;; this makes longer expressions clearer, but short expressions a little more cumbersome
;; ;; ;; Maybe I want to enforce this. Maybe.
(css ((:and
(do ~ re @ mi) (fa ~ so @ la :ti :do))
:padding 40))
;; wrong
(css (((do ~ re @ mi) (fa ~ bah) ~ so @ la :ti :do)
:padding 40))
(css (((foo ~ do re mi @ ping pong)
(fa ~ so la @ bar (_ jar "mar") (- mama "gaga") (papa "dada")))
:padding 40))
(css ((:and
(foo ~ do re mi @ ping pong)
(fa ~ so la @ bar (_ jar "mar") (- mama "gaga") (papa "dada")))
:padding 40))
(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))
(css (body :padding 6pt)
((or repl repl2)
;; cascading related to fonts
:font-family courier
(.some-silly-class
:font-family comic
(.more-class :font-color blue))
:overflow scroll
:height 90%
;; cascading related to box
:border solid thin
:padding 6pt
(.some-silly-class :padding 20pt :border dashed red double)
))
(css (body :padding 6pt)
((( div .repl) (div .repl2)) ;; and or by default
;; cascading related to fonts
:font-family courier
(.some-silly-class
:font-family comic
(.more-class :font-color blue))
:overflow scroll
:height 90%
;; cascading related to box
:border solid thin
:padding 6pt
(.some-silly-class :padding 20pt :border dashed red double)
(.some-other-class :padding 0pt)
))
;; (emit-css (body padding "6pt")
;; ((:id "repl")
;; font-family courier
;; overflow scroll
;; height "90%"
;; border "solid thin"
;; padding "6pt")
;; ((and (:id "messages") p)
;; background "#ddddff"
;; padding "3pt"
;; margin-top "0pt"
;; margin-bottom "0pt"
;; font-size "12pt")
;; ((and (:id "debugging") p)
;; background "#ffddff"
;; padding "3pt"
;; margin-top "0pt"
;; margin-bottom "0pt"
;; font-size "12pt")
;; ((and (:id "channel-log") p)
;; background "#ffddbb"
;; padding "3pt"
;; margin-top "0pt"
;; margin-bottom "0pt"
;; font-size "12pt")
;; (p padding "0pt")
;; (input w:idth "100%")
;; ((:id arglists)
;; color "#bbbbbb"
;; background "#666666"
;; border "sol:id thin")
;; (.prompt color "#aaaaaa")
;; (.input color "#000000" font-weight bold padding "0pt" padding-top "6pt" margin "0pt")
;; (.result color "#0000ff" padding-top "3pt" margin "0pt")
;; (.output color "#ff00ff" padding-top "3pt" margin "0pt")
;; (.error color "#ff0000" padding-top "3pt" margin "0pt"))
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