1 (in-package :parenscript.javascript
)
3 (defgeneric js-to-strings
(expression start-pos
)
4 (:documentation
"Transform an enscript-javascript expression to a string"))
6 (defgeneric js-to-statement-strings
(code-fragment start-pos
)
7 (:documentation
"Transform an enscript-javascript code fragment to a string"))
11 (defun special-append-to-last (form elt
)
12 (flet ((special-append (form elt
)
13 (let ((len (length form
)))
15 (string= (char form
(1- len
)) elt
))
17 (concatenate 'string form elt
)))))
19 (special-append form elt
))
21 (let ((last (last form
)))
22 (if (stringp (car last
))
23 (rplaca last
(special-append (car last
) elt
))
24 (append-to-last (car last
) elt
))
26 (t (error "unsupported form ~S" form
)))))
28 (defun dwim-join (value-string-lists max-length
33 (white-space (make-string (length start
) :initial-element
#\Space
))
35 (append-to-last #'append-to-last
)
38 (format t
"value-string-lists: ~S~%" value-string-lists
)
40 ;;; collect single value-string-lists until line full
42 (do* ((string-lists value-string-lists
(cdr string-lists
))
43 (string-list (car string-lists
) (car string-lists
))
52 (list (concatenate 'string start end
))
56 (funcall append-to-last
(first res
) end
)))
59 (format t
"string-list: ~S~%" string-list
)
62 (unless (null (cdr string-lists
))
63 (funcall append-to-last string-list join-after
)))
65 (if (and collect
(= (length string-list
) 1))
68 (format t
"cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
70 (+ (length (first string-list
))
75 (< (+ (length (first string-list
))
76 (length cur-elt
)) max-length
))
78 (concatenate 'string cur-elt
79 (if (or is-first
(and cur-empty
(string= join-before
"")))
80 "" (concatenate 'string separator join-before
))
85 (setf cur-elt
(concatenate 'string white-space
86 join-before
(first string-list
))
92 (setf cur-elt white-space
94 (setf res
(nconc (nreverse
95 (cons (concatenate 'string
100 (mapcar #'(lambda (x) (concatenate 'string white-space x
))
103 (setf cur-elt white-space cur-empty t
)))))
105 (defmethod js-to-strings ((expression expression
) start-pos
)
106 (declare (ignore start-pos
))
107 (list (princ-to-string (value expression
))))
109 (defmethod js-to-statement-strings ((expression expression
) start-pos
)
110 (js-to-strings expression start-pos
))
112 (defmethod js-to-statement-strings ((statement statement
) start-pos
)
113 (declare (ignore start-pos
))
114 (list (princ-to-string (value statement
))))
116 (defmethod js-to-strings ((expression script-quote
) start-pos
)
117 (declare (ignore start-pos
))
119 (if (null (value expression
))
121 (case (value expression
)
122 (t (error "Cannot translated quoted value ~s to javascript" (value expression
)))))))
126 (defmethod js-to-strings ((array array-literal
) start-pos
)
127 (let ((value-string-lists
128 (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
129 (array-values array
)))
130 (max-length (- 80 start-pos
2)))
131 (dwim-join value-string-lists max-length
132 :start
"[ " :end
" ]"
135 (defmethod js-to-strings ((aref js-aref
) start-pos
)
136 (dwim-join (cons (js-to-strings (aref-array aref
) start-pos
)
137 (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x
(+ start-pos
2)))
139 :start
"[" :end
"]"))
141 (- 80 start-pos
2) :separator
""
144 ;;; object literals (maps and hash-tables)
146 (defmethod js-to-strings ((obj object-literal
) start-pos
)
149 for
(key . value
) in
(object-values obj
)
151 (dwim-join (list (list (format nil
"~A:" (js-translate-symbol key
)))
152 (js-to-strings value
(+ start-pos
2)))
154 :start
"" :end
"" :join-after
"")))
156 :start
"{ " :end
" }"
161 (defvar *js-quote-char
* #\'
162 "Specifies which character JS sholud use for delimiting strings.
164 This variable is usefull when have to embed some javascript code
165 in an html attribute delimited by #\\\" as opposed to #\\', or
168 (defparameter *js-lisp-escaped-chars
*
172 (#\f .
#.
(code-char 12))
177 (defun lisp-special-char-to-js (lisp-char)
178 (car (rassoc lisp-char
*js-lisp-escaped-chars
*)))
180 (defmethod js-to-strings ((string string-literal
) start-pos
)
181 (declare (ignore start-pos
)
182 (inline lisp-special-char-to-js
))
183 (list (with-output-to-string (escaped)
184 (write-char *js-quote-char
* escaped
)
186 for char across
(value string
)
187 for code
= (char-code char
)
188 for special
= (lisp-special-char-to-js char
)
192 (write-char #\\ escaped
)
193 (write-char special escaped
))
194 ((or (<= code
#x1f
) (>= code
#x80
))
195 (format escaped
"\\u~4,'0x" code
))
196 (t (write-char char escaped
)))
197 finally
(write-char *js-quote-char
* escaped
)))))
200 (defgeneric js-translate-symbol-contextually
(symbol package env
)
201 (:documentation
"Translates a symbol to a string in the given environment & package
202 and for the given symbol."))
204 (defparameter *obfuscate-standard-identifiers
* nil
)
206 (defparameter *obfuscation-table
* (make-hash-table))
208 (defun obfuscated-symbol (symbol)
209 (or (gethash symbol
*obfuscation-table
*)
210 (setf (gethash symbol
*obfuscation-table
*) (string (gensym)))))
212 (defmethod js-translate-symbol-contextually ((symbol symbol
)
213 (package ps
::script-package
)
214 (env ps
::compilation-environment
))
216 ((member (ps::script-package-lisp-package package
)
217 (mapcar #'find-package
'(:keyword
:parenscript.global
)))
218 (symbol-to-js symbol
))
219 (*obfuscate-standard-identifiers
*
220 (obfuscated-symbol symbol
))
222 (case *package-prefix-style
*
225 (or (ps::script-package-prefix package
) (concatenate 'string
(ps::script-package-name package
) "_"))
226 (symbol-to-js symbol
)))
228 (symbol-to-js (value symbol
)))))))
230 (defgeneric js-translate-symbol
(var)
231 (:documentation
"Given a JS-VARIABLE returns an output
232 JavaScript version of it as a string."))
234 (defmethod js-translate-symbol ((var js-variable
))
235 (js-translate-symbol (value var
)))
237 (defmethod js-translate-symbol ((var-name symbol
))
238 (js-translate-symbol-contextually var-name
(ps::symbol-script-package var-name
) ps
::*compilation-environment
*))
240 (defmethod js-to-strings ((v js-variable
) start-form
)
241 (declare (ignore start-form
))
242 (list (js-translate-symbol v
)))
244 ;;; arithmetic operators
245 (defun script-convert-op-name (op)
254 (defun op-form-p (form)
256 (not (script-special-form-p form
))
257 (not (null (op-precedence (first form
))))))
259 (defun klammer (string-list)
260 (prepend-to-first string-list
"(")
261 (append-to-last string-list
")")
264 (defmethod expression-precedence ((expression expression
))
267 (defmethod expression-precedence ((form op-form
))
268 (op-precedence (operator form
)))
270 (defmethod js-to-strings ((form op-form
) start-pos
)
271 (let* ((precedence (expression-precedence form
))
273 (mapcar #'(lambda (x)
274 (let ((string-list (js-to-strings x
(+ start-pos
2))))
275 (if (>= (expression-precedence x
) precedence
)
276 (klammer string-list
)
279 (max-length (- 80 start-pos
2))
280 (op-string (format nil
"~A " (operator form
))))
281 (dwim-join value-string-lists max-length
:join-before op-string
)
284 (defmethod js-to-strings ((one-op one-op
) start-pos
)
285 (let* ((value (value one-op
))
286 (value-strings (js-to-strings value start-pos
)))
287 (when (typep value
'op-form
)
288 (setf value-strings
(klammer value-strings
)))
289 (if (one-op-pre-p one-op
)
290 (prepend-to-first value-strings
292 (append-to-last value-strings
297 (defmethod js-to-strings ((form function-call
) start-pos
)
298 (let* ((value-string-lists
299 (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
301 (max-length (- 80 start-pos
2))
302 (args (dwim-join value-string-lists max-length
303 :start
"(" :end
")" :join-after
",")))
304 (etypecase (f-function form
)
306 (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form
) (+ start-pos
2)))
308 :start
"(" :end
")" :separator
"")
312 ((or js-variable js-aref js-slot-value
)
313 (dwim-join (list (js-to-strings (f-function form
) (+ start-pos
2))
318 ;; TODO it adds superfluous newlines after each ()
319 ;; and it's nearly the same as the js-lambda case above
320 (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form
) (+ start-pos
2)))
321 max-length
:separator
"")
323 max-length
:separator
"")))))
325 (defmethod js-to-strings ((form method-call
) start-pos
)
326 (let ((object (js-to-strings (m-object form
) (+ start-pos
2))))
327 ;; TODO: this may not be the best way to add ()'s around lambdas
328 ;; probably there is or should be a more general solution working
329 ;; in other situations involving lambda's
330 (when (member (m-object form
) (list 'js-lambda
'number-literal
'js-object
'op-form
)
333 (nconc object
(list ")")))
334 (let* ((fname (dwim-join (list object
335 (list (js-translate-symbol (m-method form
))))
339 (butlast (butlast fname
))
340 (last (car (last fname
)))
341 (method-and-args (dwim-join (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
347 (ensure-no-newline-before-dot (concatenate 'string
349 (first method-and-args
))))
350 (nconc (butlast butlast
)
351 (list ensure-no-newline-before-dot
)
352 (rest method-and-args
)))))
354 ;;; optimization that gets rid of nested blocks, which have no meaningful effect
356 (defgeneric expanded-subblocks
(block)
359 (:method
((block js-block
))
360 (mapcan #'expanded-subblocks
(block-statements block
))))
362 (defun consolidate-subblocks (block)
363 (setf (block-statements block
) (expanded-subblocks block
))
367 (defmethod js-to-statement-strings ((body js-block
) start-pos
)
368 (consolidate-subblocks body
)
369 (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x
(+ start-pos
2)))
370 (block-statements body
))
373 :append-to-last
#'special-append-to-last
374 :start
(block-indent body
) :collect nil
377 (defmethod js-to-strings ((body js-block
) start-pos
)
378 (dwim-join (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
379 (block-statements body
))
381 :append-to-last
#'special-append-to-last
383 :start
(block-indent body
)))
386 (defmethod js-to-statement-strings ((body js-sub-block
) start-pos
)
387 (declare (ignore start-pos
))
388 (nconc (list "{") (call-next-method) (list "}")))
390 ;;; function definition
391 (defmethod js-to-strings ((lambda js-lambda
) start-pos
)
392 (let ((fun-header (dwim-join (mapcar #'(lambda (x)
393 (list (js-translate-symbol x
)))
394 (lambda-args lambda
))
396 :start
(function-start-string lambda
)
397 :end
") {" :join-after
","))
398 (fun-body (js-to-statement-strings (lambda-body lambda
) (+ start-pos
2))))
399 (nconc fun-header fun-body
(list "}"))))
401 (defgeneric function-start-string
(function)
402 (:documentation
"Returns the string that starts the function - this varies according to whether
403 this is a lambda or a defun"))
405 (defmethod function-start-string ((lambda js-lambda
))
408 (defmethod js-to-statement-strings ((lambda js-lambda
) start-pos
)
409 (js-to-strings lambda start-pos
))
411 (defmethod function-start-string ((defun js-defun))
412 (format nil
"function ~A(" (js-translate-symbol (defun-name defun
))))
415 (defmethod js-to-strings ((object js-object
) start-pos
)
416 (let ((value-string-lists
417 (mapcar #'(lambda (slot)
418 (let* ((slot-name (first slot
))
420 (if (typep slot-name
'script-quote
)
421 (if (symbolp (value slot-name
))
422 (format nil
"~A" (js-translate-symbol (value slot-name
)))
423 (format nil
"~A" (first (js-to-strings slot-name
0))))
424 (car (js-to-strings slot-name
0)))))
425 (dwim-join (list (js-to-strings (second slot
) (+ start-pos
4)))
427 :start
(concatenate 'string slot-string-name
" : ")
430 (max-length (- 80 start-pos
2)))
431 (dwim-join value-string-lists max-length
438 (defmethod js-to-strings ((sv js-slot-value
) start-pos
)
439 (append-to-last (if (typep (sv-object sv
) 'js-variable
)
440 (js-to-strings (sv-object sv
) start-pos
)
441 (list (format nil
"~A" (js-to-strings (sv-object sv
) start-pos
))))
442 (if (typep (sv-slot sv
) 'script-quote
)
443 (if (symbolp (value (sv-slot sv
)))
444 (format nil
".~A" (js-translate-symbol (value (sv-slot sv
))))
445 (format nil
".~A" (first (js-to-strings (sv-slot sv
) 0))))
446 (format nil
"[~A]" (first (js-to-strings (sv-slot sv
) 0))))))
449 (defmethod js-to-statement-strings ((cond js-cond
) start-pos
)
450 (loop :for body
:on
(cond-bodies cond
)
451 :for first
= (eq body
(cond-bodies cond
))
452 :for last
= (not (cdr body
))
453 :for test
:in
(cond-tests cond
)
454 :append
(if (and last
(not first
) (string= (value test
) "true"))
456 (dwim-join (list (js-to-strings test
0)) (- 80 start-pos
2)
457 :start
(if first
"if (" "else if (") :end
") {"))
458 :append
(js-to-statement-strings (car body
) (+ start-pos
2))
461 (defmethod js-to-statement-strings ((if js-if
) start-pos
)
462 (let ((if-strings (dwim-join (list (js-to-strings (if-test if
) 0))
466 (then-strings (js-to-statement-strings (if-then if
) (+ start-pos
2)))
467 (else-strings (when (if-else if
)
468 (js-to-statement-strings (if-else if
)
470 (nconc if-strings then-strings
(if else-strings
471 (nconc (list "} else {") else-strings
(list "}"))
474 (defmethod js-to-strings ((if js-if
) start-pos
)
475 (assert (typep (if-then if
) 'expression
))
477 (assert (typep (if-else if
) 'expression
)))
478 (dwim-join (list (append-to-last (js-to-strings (if-test if
) start-pos
) " ?")
479 (let* ((new-then (make-instance 'js-block
480 :statements
(block-statements (if-then if
))
482 (res (js-to-strings new-then start-pos
)))
483 (if (>= (expression-precedence (if-then if
))
484 (expression-precedence if
))
489 (let* ((new-else (make-instance 'js-block
490 :statements
(block-statements (if-else if
))
492 (res (js-to-strings new-else start-pos
)))
493 (if (>= (expression-precedence (if-else if
))
494 (expression-precedence if
))
502 (defmethod js-to-strings ((setf js-setf
) start-pos
)
503 (dwim-join (cons (js-to-strings (setf-lhs setf
) start-pos
)
504 (mapcar #'(lambda (x) (js-to-strings x start-pos
)) (setf-rhsides setf
)))
509 (defmethod js-to-statement-strings ((defvar js-defvar
) start-pos
)
510 (dwim-join (nconc (mapcar #'(lambda (x) (list (js-translate-symbol x
))) (var-names defvar
))
511 (when (var-value defvar
)
512 (list (js-to-strings (var-value defvar
) start-pos
))))
515 :start
"var " :end
";"))
518 (defmethod js-to-statement-strings ((for js-for
) start-pos
)
519 (let* ((init (dwim-join (mapcar #'(lambda (x)
520 (dwim-join (list (list (js-translate-symbol (first (var-names x
))))
521 (js-to-strings (var-value x
)
527 :start
"var " :join-after
","))
528 (check (js-to-strings (for-check for
) (+ start-pos
2)))
529 (steps (dwim-join (mapcar #'(lambda (x var
)
531 (list (list (js-translate-symbol (first (var-names var
))))
532 (js-to-strings x
(- start-pos
2)))
539 (header (dwim-join (list init check steps
)
541 :start
"for (" :end
") {"
543 (body (js-to-statement-strings (for-body for
) (+ start-pos
2))))
544 (nconc header body
(list "}"))))
547 (defmethod js-to-statement-strings ((fe for-each
) start-pos
)
548 (let ((header (dwim-join (list (list (js-translate-symbol (fe-name fe
)))
550 (js-to-strings (fe-value fe
) (+ start-pos
2)))
554 (body (js-to-statement-strings (fe-body fe
) (+ start-pos
2))))
555 (nconc header body
(list "}"))))
557 (defmethod js-to-statement-strings ((while js-while
) start-pos
)
558 (let ((header (dwim-join (list (js-to-strings (while-check while
) (+ start-pos
2)))
562 (body (js-to-statement-strings (while-body while
) (+ start-pos
2))))
563 (nconc header body
(list "}"))))
566 (defmethod js-to-statement-strings ((with js-with
) start-pos
)
567 (nconc (dwim-join (list (js-to-strings (with-obj with
) (+ start-pos
2)))
569 :start
"with (" :end
") {")
570 (js-to-statement-strings (with-body with
) (+ start-pos
2))
574 (defmethod js-to-statement-strings ((case js-switch
) start-pos
)
575 (let ((body (mapcan #'(lambda (clause)
576 (let ((val (car clause
))
577 (body (second clause
)))
578 (dwim-join (list (if (eql val
'default
)
580 (js-to-strings val
(+ start-pos
2)))
581 (js-to-statement-strings body
(+ start-pos
2)))
583 :start
(if (eql val
'default
) " default" " case ")
585 :join-after
":"))) (case-clauses case
))))
588 (format t
"body: ~S~%" body
)
589 (nconc (dwim-join (list (js-to-strings (case-value case
) (+ start-pos
2)))
591 :start
"switch (" :end
") {")
596 (defmethod js-to-statement-strings ((try js-try
) start-pos
)
597 (let* ((catch (try-catch try
))
598 (finally (try-finally try
))
599 (catch-list (when catch
601 (dwim-join (list (list (js-translate-symbol (first catch
))))
605 (js-to-statement-strings (second catch
) (+ start-pos
2)))))
606 (finally-list (when finally
607 (nconc (list "} finally {")
608 (js-to-statement-strings finally
(+ start-pos
2))))))
609 (nconc (list "try {")
610 (js-to-statement-strings (try-body try
) (+ start-pos
2))
616 (defun first-slash-p (string)
617 (and (> (length string
) 0)
618 (eq (char string
0) '#\
/)))
620 (defmethod js-to-strings ((regex regex
) start-pos
)
621 (declare (ignore start-pos
))
622 (let ((slash (if (first-slash-p (value regex
)) nil
"/")))
623 (list (format nil
(concatenate 'string slash
"~A" slash
) (value regex
)))))
625 ;;; conditional compilation
626 (defmethod js-to-statement-strings ((cc cc-if
) start-pos
)
627 (nconc (list (format nil
"/*@if ~A" (cc-if-test cc
)))
628 (mapcan #'(lambda (x) (js-to-strings x start-pos
)) (cc-if-body cc
))
633 (defmethod js-to-strings ((instanceof js-instanceof
) start-pos
)
635 (list (js-to-strings (value instanceof
) (+ start-pos
2))
637 (js-to-strings (slot-value instanceof
'type
) (+ start-pos
2)))
644 ;;; single operations
645 (defmacro define-translate-js-single-op
(name &optional
(superclass 'expression
))
646 (let ((script-name (intern (concatenate 'string
"JS-" (symbol-name name
)) #.
*package
*)))
647 `(defmethod ,(if (eql superclass
'expression
)
649 'js-to-statement-strings
)
650 ((,name
,script-name
) start-pos
)
651 (dwim-join (list (js-to-strings (value ,name
) (+ start-pos
2)))
653 :start
,(concatenate 'string
(string-downcase (symbol-name name
)) " ")
656 (define-translate-js-single-op return statement
)
657 (define-translate-js-single-op throw statement
)
658 (define-translate-js-single-op delete
)
659 (define-translate-js-single-op void
)
660 (define-translate-js-single-op typeof
)
661 (define-translate-js-single-op new
)