1 (in-package :parenscript
)
3 (defgeneric ps-print%
(special-form-name special-form-args %start-pos%
))
5 (defmacro defprinter
(special-form content-args
&body body
)
6 "Given a special-form name and a destructuring lambda-list for its
7 arguments, defines a printer for that form using the given body."
10 `(defmethod ps-print%
((,sf
(eql ',special-form
)) ,sf-args %start-pos%
)
11 (declare (ignore ,sf
))
12 (destructuring-bind ,content-args
18 (defgeneric ps-print
(compiled-form %start-pos%
))
20 (defmethod ps-print ((compiled-form cons
) %start-pos%
)
21 "Prints the given compiled ParenScript form starting at the given
23 (ps-print%
(car compiled-form
) (cdr compiled-form
) %start-pos%
))
26 (defvar *js-quote-char
* #\'
27 "Specifies which character JS should use for delimiting strings.
29 This variable is useful when have to embed some javascript code
30 in an html attribute delimited by #\\\" as opposed to #\\', or
33 (defparameter *js-lisp-escaped-chars
*
37 (#\f .
#.
(code-char 12))
42 (defmethod ps-print ((string string
) %start-pos%
)
43 (flet ((lisp-special-char-to-js (lisp-char)
44 (car (rassoc lisp-char
*js-lisp-escaped-chars
*))))
45 (list (with-output-to-string (escaped)
46 (write-char *js-quote-char
* escaped
)
47 (loop for char across string
48 for code
= (char-code char
)
49 for special
= (lisp-special-char-to-js char
)
52 (write-char #\\ escaped
)
53 (write-char special escaped
))
54 ((or (<= code
#x1f
) (>= code
#x80
))
55 (format escaped
"\\u~4,'0x" code
))
56 (t (write-char char escaped
)))
57 finally
(write-char *js-quote-char
* escaped
))))))
59 (defmethod ps-print ((number number
) %start-pos%
)
60 (list (format nil
(if (integerp number
) "~S" "~F") number
)))
62 ;;; expression and operator precedence rules
64 (defun expression-precedence (expr)
67 (js-block (if (= (length (cdr expr
)) 1)
68 (expression-precedence (first (cdr expr
)))
69 (op-precedence 'comma
)))
70 (js-expression-if (op-precedence 'js-expression-if
))
71 (js-assign (op-precedence '=))
72 (operator (op-precedence (second expr
)))
76 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
77 (defparameter *op-precedence-hash
* (make-hash-table :test
#'equal
))
79 ;;; generate the operator precedences from *OP-PRECEDENCES*
81 (dolist (ops '((js-aref)
97 (js-assign *= /= %
= += -
= <<= >>= >>>= \
&= ^
= \|
=)
100 (let ((op-name (symbol-name op
)))
101 (setf (gethash op-name
*op-precedence-hash
*) precedence
)))
104 (defun op-precedence (op)
105 (gethash (if (symbolp op
)
108 *op-precedence-hash
*)))
112 (defmacro max-length
() '(- 80 %start-pos%
2))
114 (defun ps-print-indent (ps-form)
115 (ps-print ps-form
(+ %start-pos%
2)))
117 (defun special-append-to-last (form elt
)
118 (flet ((special-append (form elt
)
119 (let ((len (length form
)))
121 (string= (char form
(1- len
)) elt
))
123 (concatenate 'string form elt
)))))
124 (cond ((stringp form
)
125 (special-append form elt
))
127 (let ((last (last form
)))
128 (if (stringp (car last
))
129 (rplaca last
(special-append (car last
) elt
))
130 (append-to-last (car last
) elt
))
132 (t (error "Wrong argument type to indent appender: ~S" form
)))))
134 (defun dwim-join (value-string-lists max-length
139 (white-space (make-string (length start
) :initial-element
#\Space
))
141 (append-to-last #'append-to-last
)
144 (format t
"value-string-lists: ~S~%" value-string-lists
)
146 ;;; collect single value-string-lists until the line is full
148 (do* ((string-lists value-string-lists
(cdr string-lists
))
149 (string-list (car string-lists
) (car string-lists
))
158 (list (concatenate 'string start end
))
162 (funcall append-to-last
(first res
) end
)))
165 (format t
"string-list: ~S~%" string-list
)
168 (unless (null (cdr string-lists
))
169 (funcall append-to-last string-list join-after
)))
171 (if (and collect
(= (length string-list
) 1))
174 (format t
"cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
176 (+ (length (first string-list
))
181 (< (+ (length (first string-list
))
182 (length cur-elt
)) max-length
))
184 (concatenate 'string cur-elt
185 (if (or is-first
(and cur-empty
(string= join-before
"")))
186 "" (concatenate 'string separator join-before
))
191 (setf cur-elt
(concatenate 'string white-space
192 join-before
(first string-list
))
198 (setf cur-elt white-space
200 (setf res
(nconc (nreverse
201 (cons (concatenate 'string
206 (mapcar #'(lambda (x) (concatenate 'string white-space x
))
209 (setf cur-elt white-space cur-empty t
)))))
211 (defprinter script-quote
(val)
214 (error "Cannot translate quoted value ~S to javascript" val
)))
216 (defprinter js-literal
(str)
219 (defprinter js-keyword
(str)
224 (defprinter array-literal
(&rest initial-contents
)
225 (let ((initial-contents-strings (mapcar #'ps-print-indent initial-contents
)))
226 (dwim-join initial-contents-strings
(max-length)
227 :start
"[ " :end
" ]"
230 (defprinter js-aref
(array coords
)
231 (dwim-join (cons (ps-print array %start-pos%
)
232 (mapcar (lambda (x) (dwim-join (list (ps-print-indent x
))
234 :start
"[" :end
"]"))
240 (defprinter object-literal
(&rest arrows
)
241 (dwim-join (loop for
(key . value
) in arrows appending
242 (list (dwim-join (list (list (format nil
"~A:" (js-translate-symbol key
)))
243 (ps-print-indent value
))
245 :start
"" :end
"" :join-after
"")))
247 :start
"{ " :end
" }"
250 (defprinter js-variable
(var)
251 (list (js-translate-symbol var
)))
253 ;;; arithmetic operators
254 (defun script-convert-op-name (op)
263 (defun parenthesize (string-list)
264 (prepend-to-first string-list
"(")
265 (append-to-last string-list
")")
268 (defprinter operator
(op args
)
269 (let* ((precedence (op-precedence op
))
270 (arg-strings (mapcar (lambda (arg)
271 (let ((arg-strings (ps-print-indent arg
)))
272 (if (>= (expression-precedence arg
) precedence
)
273 (parenthesize arg-strings
)
276 (op-string (format nil
"~A " op
)))
277 (dwim-join arg-strings
(max-length) :join-before op-string
)))
279 (defprinter unary-operator
(op arg
&key prefix
)
280 (let ((arg-string (ps-print arg %start-pos%
)))
281 (when (eql 'operator
(car arg
))
282 (setf arg-string
(parenthesize arg-string
)))
284 (prepend-to-first arg-string op
)
285 (append-to-last arg-string op
))))
287 ;;; function and method calls
288 (defprinter js-funcall
(fun-designator args
)
289 (let* ((arg-strings (mapcar #'ps-print-indent args
))
290 (args (dwim-join arg-strings
(max-length)
291 :start
"(" :end
")" :join-after
",")))
292 (cond ((eql 'js-lambda
(car fun-designator
))
293 (dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator
))
295 :start
"(" :end
")" :separator
"")
299 ((member (car fun-designator
) '(js-variable js-aref js-slot-value
))
300 (dwim-join (list (ps-print-indent fun-designator
) args
)
303 ((eql 'js-funcall
(car fun-designator
))
304 ;; TODO it adds superfluous newlines after each ()
305 ;; and it's nearly the same as the js-lambda case above
306 (dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator
))
307 (max-length) :separator
"")
309 (max-length) :separator
"")))))
311 (defprinter js-method-call
(method object args
)
312 (let ((printed-object (ps-print object
(+ %start-pos%
2))))
313 ;; TODO: this may not be the best way to add ()'s around lambdas
314 ;; probably there is or should be a more general solution working
315 ;; in other situations involving lambda's
316 (when (or (numberp object
) (and (consp object
) (member (car object
) '(js-lambda js-object operator
))))
317 (setf printed-object
(append (list "(") printed-object
(list ")"))))
318 (let* ((fname (dwim-join (list printed-object
(list (js-translate-symbol method
)))
322 (butlast (butlast fname
))
323 (last (car (last fname
)))
324 (method-and-args (dwim-join (mapcar #'ps-print-indent args
)
329 (ensure-no-newline-before-dot (concatenate 'string
331 (first method-and-args
))))
332 (append (butlast butlast
) (list ensure-no-newline-before-dot
) (cdr method-and-args
)))))
334 (defprinter js-block
(statement-p statements
)
335 (dwim-join (mapcar #'ps-print-indent statements
)
337 :join-after
(if statement-p
";" ",")
338 :append-to-last
#'special-append-to-last
339 :start
(if statement-p
" " "")
341 :end
(if statement-p
";" "")))
343 (defprinter js-lambda
(args body
)
344 (print-fun-def nil args body %start-pos%
))
346 (defprinter js-defun
(name args body
)
347 (print-fun-def name args body %start-pos%
))
349 (defun print-fun-def (name args body %start-pos%
)
350 (let ((fun-header (dwim-join (mapcar (lambda (x) (list (js-translate-symbol x
)))
353 :start
(format nil
"function ~:[~;~A~](" name
(js-translate-symbol name
))
356 (fun-body (ps-print-indent body
)))
357 (append fun-header fun-body
(list "}"))))
360 (defprinter js-object
(slot-defs)
361 (let ((value-string-lists (mapcar (lambda (slot)
362 (let* ((slot-name (first slot
))
364 (if (and (listp slot-name
) (eql 'script-quote
(car slot-name
)))
365 (format nil
"~A" (if (symbolp (second slot-name
))
366 (js-translate-symbol (second slot-name
))
367 (car (ps-print slot-name
0))))
368 (car (ps-print slot-name
0)))))
369 (dwim-join (list (ps-print (second slot
) (+ %start-pos%
4)))
371 :start
(concatenate 'string slot-string-name
" : ")
374 (dwim-join value-string-lists
(max-length)
381 (defprinter js-slot-value
(obj slot
)
382 (append-to-last (if (and (listp obj
) (eql 'js-variable
(car obj
)))
383 (ps-print obj %start-pos%
)
384 (list (format nil
"~A" (ps-print obj %start-pos%
))))
385 (if (and (listp slot
) (eql 'script-quote
(car slot
)))
386 (format nil
".~A" (if (symbolp (second slot
))
387 (js-translate-symbol (second slot
))
388 (first (ps-print slot
0))))
389 (format nil
"[~A]" (first (ps-print slot
0))))))
392 (defprinter js-cond
(clauses)
393 (loop for
(test body-forms
) in clauses
394 for start
= "if (" then
"else if ("
395 append
(if (string= test
"true")
397 (dwim-join (list (ps-print test
0)) (max-length)
398 :start start
:end
") {"))
399 append
(mapcar #'ps-print-indent body-forms
)
402 (defprinter js-statement-if
(test then else
)
403 (let ((if-strings (dwim-join (list (ps-print test
0))
407 (then-strings (ps-print-indent then
))
408 (else-strings (when else
409 (ps-print-indent else
))))
410 (append if-strings then-strings
(if else-strings
411 (append (list "} else {") else-strings
(list "}"))
414 (defprinter js-expression-if
(test then else
)
415 (dwim-join (list (append-to-last (ps-print test %start-pos%
) " ?")
416 (let ((then-string (ps-print then %start-pos%
)))
417 (if (>= (expression-precedence then
) (op-precedence 'js-expression-if
))
418 (parenthesize then-string
)
422 (let ((else-string (ps-print else %start-pos%
)))
423 (if (>= (expression-precedence else
) (op-precedence 'js-expression-if
))
424 (parenthesize else-string
)
430 (defprinter js-assign
(lhs rhs
)
431 (dwim-join (list (ps-print lhs %start-pos%
) (ps-print rhs %start-pos%
))
435 (defprinter js-defvar
(var-name &rest var-value
)
436 (dwim-join (append (list (list (js-translate-symbol var-name
)))
438 (list (ps-print (car var-value
) %start-pos%
))))
441 :start
"var " :end
";"))
444 (defprinter js-for
(vars steps test body-block
)
445 (let* ((init (dwim-join (mapcar (lambda (var-form)
446 (dwim-join (list (list (js-translate-symbol (car var-form
)))
447 (ps-print-indent (cdr var-form
)))
452 :start
"var " :join-after
","))
453 (test-string (ps-print-indent test
))
454 (step-strings (dwim-join (mapcar (lambda (x var-form
)
456 (list (list (js-translate-symbol (car var-form
)))
457 (ps-print x
(- %start-pos%
2)))
464 (header (dwim-join (list init test-string step-strings
)
466 :start
"for (" :end
") {"
468 (body (ps-print-indent body-block
)))
469 (append header body
(list "}"))))
471 (defprinter js-for-each
(var object body-block
)
472 (let ((header (dwim-join (list (list (js-translate-symbol var
))
474 (ps-print-indent object
))
478 (body (ps-print-indent body-block
)))
479 (append header body
(list "}"))))
481 (defprinter js-while
(test body-block
)
482 (let ((header-strings (dwim-join (list (ps-print-indent test
))
486 (body-strings (ps-print-indent body-block
)))
487 (append header-strings body-strings
(list "}"))))
489 (defprinter js-with
(expression body-block
)
490 (append (dwim-join (list (ps-print-indent expression
))
492 :start
"with (" :end
") {")
493 (ps-print-indent body-block
)
496 (defprinter js-switch
(test clauses
)
497 (let ((body-strings (mapcar (lambda (clause)
498 (let ((val (first clause
))
499 (body-block (second clause
)))
500 (dwim-join (list (if (eql val
'default
)
502 (ps-print-indent val
))
503 (ps-print-indent body-block
))
505 :start
(if (eql val
'default
) " default" " case ")
509 (append (dwim-join (list (ps-print-indent test
))
511 :start
"switch (" :end
") {")
512 (reduce #'append body-strings
)
515 (defprinter js-try
(body &key catch finally
)
516 (let ((catch-strings (when catch
517 (append (dwim-join (list (list (js-translate-symbol (first catch
))))
521 (ps-print-indent (second catch
)))))
522 (finally-strings (when finally
523 (append (list "} finally {")
524 (ps-print-indent finally
)))))
525 (append (list "try {")
526 (ps-print-indent body
)
532 (defprinter js-regex
(regex)
533 (flet ((first-slash-p (string)
534 (and (> (length string
) 0) (eql (char string
0) '#\
/))))
535 (let ((slash (unless (first-slash-p regex
) "/")))
536 (list (format nil
(concatenate 'string slash
"~A" slash
) regex
)))))
538 (defprinter js-return
(value)
539 (let ((printed-value (ps-print value
0)))
540 (cons (concatenate 'string
"return " (car printed-value
)) (cdr printed-value
))))
542 ;;; conditional compilation
543 (defprinter cc-if
(test body-forms
)
544 (append (list (format nil
"/*@if ~A" test
))
545 (mapcar (lambda (x) (ps-print x %start-pos%
)) body-forms
)
549 (defprinter js-instanceof
(value type
)
550 (dwim-join (list (ps-print-indent value
)
552 (ps-print-indent type
))
558 (defprinter js-named-operator
(op value
)
559 (dwim-join (list (ps-print-indent value
))
561 :start
(concatenate 'string
(string-downcase (symbol-name op
)) " ")