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

Integration of dojo.widget

Supporting more dojo widgets should be easy.

darcs-hash:06546a1a74f3945011820c6be67ed3b73f3d18c6
parent 06f1d77b
;; 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)))
;; TODO: Make cascading more structurally explicit
......@@ -63,6 +7,7 @@ Return:
;;
(in-package :com.gigamonkeys.foo.css)
(use-package :wisp-util)
(defclass css (language)
()
......@@ -106,7 +51,7 @@ Return:
(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??
......@@ -116,12 +61,13 @@ Return:
(declare (ignore environment))
(cond
((css-atom? form)
(raw-string processor (princ-to-string form) t))
(raw-string processor (substitute #\# #\$ (^string form)) t))
((eql (first form) :import)
(emit-css-import processor form))
(t
(process-non-import-css processor form))))
(defun emit-css-import (processor sexp)
(let ((url (second sexp)))
(freshline processor)
......@@ -144,23 +90,35 @@ Return:
(raw-string processor "{")
(indent processor)
(freshline processor)
(loop for (k v) on attributes by #'cddr do
(process-css-key-or-value processor k)
(raw-string processor ": ")
(process-css-key-or-value processor v)
(raw-string processor ";")
(freshline processor))
(process-css-attributes processor attributes)
(freshline processor)
(unindent processor)
(freshline processor)
(raw-string processor "}")
(freshline processor)))
(defun process-css-attributes (processor attributes)
(loop
with first-item? = t
for item in attributes
when (keywordp item) do
(progn
(unless first-item? (raw-string processor ";") (freshline processor))
(raw-string processor (subst #\# #\$ (^string item)))
(raw-string processor ": ")
(setf first-item? nil))
else do (progn (process-css-key-or-value processor item)
(raw-string processor " ")))
(raw-string processor ";"))
(defun selector-group? (selector)
(eql (car selector) :or))
(and (consp selector) (eql (car selector) :or)))
(defun selector-descendents? (selector)
(eql (car selector) :and))
(and (consp selector ) (eql (car selector) :and)))
(defun emit-selector-group (processor selectors)
(loop with separator = ", "
......@@ -189,9 +147,34 @@ Return:
(values (ldiff selector pseudo-classes) pseudo-classes)
(error "pseudo-classes must be at the end of a selector expression: ~S" selector))))
;; (defun emit-selector (processor selector)
;; (cond
;; ((atom selector) (raw-string processor (string-invert (string-name 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)
;; (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 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))))
;; (when pseudo-classes (raw-string processor (format nil "~{:~a~}" pseudo-classes))))))))
(defun emit-selector (processor selector)
(cond
((atom selector) (raw-string processor (string-downcase (string selector))))
((atom selector) (raw-string processor (substitute #\# #\$ (string-invert (symbol-name 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)
......@@ -199,19 +182,8 @@ Return:
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)
(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 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))))
(when pseudo-classes (raw-string processor (format nil "~{:~a~}" pseudo-classes))))))))
(t (error "Illegal CSS Syntax in ~S" selector))))
......@@ -224,9 +196,10 @@ Return:
(defun process-css-key-or-value (processor form)
(if (keywordp form)
(raw-string processor (string-downcase form))
(raw-string processor (^string form))
(process *css* processor form nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File compiler implementation
......
;;
;; 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.
......@@ -54,59 +54,81 @@
(defmethod macro-symbol ((language javascript)) 'javascript-macro)
(defmacro js (&whole whole &body body)
(declare (ignore body))
`(macrolet ((js (&body body)
(codegen-text (sexp->ops *javascript* body (top-level-environment *javascript*)) ,*pretty*)))
,@(if *pretty*
`((let ((*text-pretty-printer* (get-pretty-printer))) ,whole))
`(,whole))))
(defmacro process-js (js-form)
`(process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*)))
`(process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*)))
(defun ~@? (car)
(member car '(~ @)))
(defun normalize-~@ (form)
;; doesn't recurse. This only normalizes within one expression.
;; doesn't recurse. This only normalizes within one expression.
(if (atom form) form
(if (member (car form) '(~ @))
(if (~@? (car form))
(loop
for (item . rest) on (cdr form)
when (member item '(~ @)) do (return (normalize-~@ `(,item ,(cons (car form) normal-items) ,@rest)))
when (~@? item) do (return (normalize-~@ `(,item ,(cons (car form) normal-items) ,@rest)))
collect item into normal-items
finally (return (cons (car form) normal-items)))
(loop
for (item . rest) on form
when (member item '(~ @)) do (return (normalize-~@ `(,item ,normal-items ,@rest)))
when (~@? item) do (return (normalize-~@ `(,item ,normal-items ,@rest)))
collect item into normal-items
finally (return normal-items)))))
;; (normalize-~@ '(a b c))
;; (normalize-~@ '(a b c))
;; (a b c)
;; (normalize-~@ '(a b c ~ d e f @ g h i ~ j k l @ m n o))
;; (normalize-~@ '(a b c ~ d e f @ g h i ~ j k l @ m n o))
;; (@ (~ (@ (~ (a b c) d e f) g h i) j k l) m n o)
(defun symbol-js-package (form)
(and (not (consp form))
(not (find-symbol (symbol-name form)))
(intern (symbol-name form) :com.gigamonkeys.foo.javascript)))
(defun ~@form? (form)
(member (car form) '(~ @)))
(defmethod process-sexp ((language javascript) processor form environment)
(if (consp form)
(let ((form (normalize-~@ form)))
(destructuring-bind (name &rest arguments) form
(cond ((~@form? form) (process language processor form
(new-env 'statement-or-expression :expression environment)))
((and (consp form) (method-name name))
(process-method-call language processor environment
(method-name name)
(first arguments)
(rest arguments)))
((consp form)
(process-function-call language processor environment
name
arguments)))))
(process-javascript-scalar processor form))
(maybe-semicolon processor environment))
;; (process-js '(foo bar 3 4 5 ~ foo ee @ joo boo ~ ee foo))
;; (process-js '(foo.bar 3 4 5 @ a b @ c d ~ e f))
;; (process-js '(foo.bar 3 4 5))
;; (process-js '(.bar foo 3 4 5 ~ foo ee))
;; This complication is to allow metasyntatical symbols to be the same in all packages.
(aif (and (consp form) (symbol-js-package (car form)))
(process language processor (cons it (cdr form)) environment)
(progn
(if (consp form)
(let ((form (normalize-~@ form)))
(destructuring-bind (name &rest arguments) form
(cond ((~@? (car form)) (process language processor form
(new-env 'statement-or-expression :expression environment)))
((and (consp form) (method-name name))
(process-method-call language processor environment
(method-name name)
(first arguments)
(rest arguments)))
((consp form)
(process-function-call language processor environment
name
arguments)))))
(process-javascript-scalar processor form))
(maybe-semicolon processor environment))))
;; (js (foo bar 3 4 5 ~ foo ee @ joo boo ~ ee foo))
;; (js (foo.bar 3 4 5 @ a b @ c d ~ e f))
;; (js (foo.bar 3 4 5))
;; (js (.bar foo 3 4 5 ~ foo ee))
(defun method-name (name)
......@@ -147,10 +169,22 @@
;; output.
(etypecase value
(string (raw-string processor (format nil "~s" value)))
(symbol (raw-string processor (format nil "~a" (dash-to-intercap value))))
(symbol (process-javascript-symbol processor value))
(number (raw-string processor (format nil "~a" value)))
(character (raw-string processor (javascript-character-text value)))))
(defun process-javascript-symbol (processor value)
(flet ((^lisp-symbol (symbol)
(if (eql (char (symbol-name symbol) 0) #\!)
(intern (subseq (symbol-name symbol) 1) (symbol-package symbol))
nil)))
(aif (^lisp-symbol value)
(progn
(raw-string processor "\"")
(embed-value processor it)
(raw-string processor "\""))
(raw-string processor (format nil "~a" (dash-to-intercap (intern (symbol-name value))))))))
......@@ -291,6 +325,7 @@ statements such as blocks to *not* emit a semicolon."
when rest do (out ", "))
" }")
(define-javascript-special-operator @ :expression (processor expr &rest slots)
(expression expr)
(loop for slot in slots do
......@@ -598,4 +633,32 @@ statements such as blocks to *not* emit a semicolon."
(export '%prog)
(remprop 'prog 'javascript-special-operator)
(remprop 'prog 'javascript-special-operator-type)
\ No newline at end of file
;; (with-foo-output (*standard-output*)
;; (process-js '(= (document.getElementById "repl" ~ innerHTML) "hello")))
;; document.getElementById("repl").innerHTML = "hello";nil
;; ~(document.getElementById("repl"), innerHTML) = "hello";nil
;; ~(document.getElementById("repl"), innerHTML) = "hello";nil
;; (normalize-~@ '(document.getElementById "repl" ~ innerHTML))
;; (with-foo-output (*standard-output*)
;; (process-js '(~ (document.getElementById "repl") innerHTML)))
;; document.getElementById("repl").innerHTML;nil
;; (with-foo-output (*standard-output*)
;; (process-js '(@ a b c)))
;;(with-foo-output (*standard-output*)
;; (process-js '(~ a b c)))
;; ~(document.getElementById("repl"), innerHTML) = "hello";nil
;; ~(document.getElementById("repl"), innerHTML) = "hello";nil
;; (macro-function 'process-js)
;; #<Interpreted Function PROCESS-JS @ #x7165bd72> ;
\ No newline at end of file
......@@ -126,26 +126,28 @@ implemented by a method on PROCESS-SEXP."
(format t "Expanding~&~s~%in environment ~s~%" form environment))
(defmethod expand-macro-form (language form environment)
(let ((macro-function (get (identifier language form) (macro-symbol language))))
(let ((macro-function (get (identifier language form) (macro-symbol language))))
(funcall macro-function form environment)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Default methods.
(defun ^symbol-in-language (symbol language)
(intern (symbol-name symbol) (input-package language)))
(defmethod identifier ((language t) (form cons))
"Reasonable default for languages with a Lispy syntax."
(and (symbolp (car form)) (car form)))
(and (symbolp (car form)) (^symbol-in-language (car form) language)))
(defmethod identifier ((language t) (form t))
(error "Malformed expression for ~a: ~s" language form))
(defmethod special-form-p ((language t) (form t)) nil)
(defmethod special-form-p ((language t) (form cons))
(print form)
(let ((identifier (identifier language form)))
(print identifier)
(defmethod special-form-p ((language t) (form cons))
(let ((identifier (identifier language form)))
(and identifier
(get identifier (special-operator-symbol language)))))
......@@ -235,7 +237,8 @@ parameter to eat up the macro name."
`(,@front ,namevar ,@back)))
(defun self-evaluating-p (form)
(and (atom form) (if (symbolp form) (keywordp form) t)))
(cond ((atom form) (if (symbolp form) (keywordp form) t))
(t (eql (car form) 'quote))))
(defun sexp->ops (language body environment)
(loop with compiler = (make-instance 'text-compiler)
......
(in-package :com.gigamonkeys.foo.javascript)
(get-pretty-printer)
(with-foo-output
(process-js '(foo bar BazBaf ~ ab cd @ la boo))
(foo bar BazBaf ~ ab cd @ la boo)
(~ (foo bar BazBaf) ab cd @ la boo)
(@ (~ (foo bar BazBaf) ab cd) la boo)
(process-js 'foo)
......@@ -148,7 +155,7 @@
(css (body :padding 6pt))
(css (body :padding 6pt)
((or repl repl2)
((:or repl repl2)
;; cascading related to fonts
:font-family courier
......@@ -167,7 +174,7 @@
))
(css (body :padding 6pt)
((( div .repl) (div .repl2)) ;; and or by default
((div.repl div.repl2) ;; and or by default
;; cascading related to fonts
:font-family courier
......@@ -186,6 +193,9 @@
))
(css ((:and div div)
:color black))
;; (emit-css (body padding "6pt")
;; ((:id "repl")
;; font-family courier
......
;;
;; Copyright (c) 2005, Gigamonkeys Consulting All rights reserved.