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 (eql nil
(value expression
))
121 (case (value expression
)
122 (t (error "Cannot translate 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
(var)
201 (:documentation
"Given a JS-VARIABLE returns an output
202 JavaScript version of it as a string."))
204 (defmethod js-translate-symbol ((var js-variable
))
205 (js-translate-symbol (value var
)))
207 (defmethod js-translate-symbol ((var-name symbol
))
208 (ps::js-translate-symbol-contextually var-name
(ps::symbol-script-package var-name
) ps
::*compilation-environment
*))
210 (defmethod js-to-strings ((v js-variable
) start-form
)
211 (declare (ignore start-form
))
212 (list (js-translate-symbol v
)))
214 ;;; arithmetic operators
215 (defun script-convert-op-name (op)
224 (defun op-form-p (form)
226 (not (script-special-form-p form
))
227 (not (null (op-precedence (first form
))))))
229 (defun klammer (string-list)
230 (prepend-to-first string-list
"(")
231 (append-to-last string-list
")")
234 (defmethod expression-precedence ((expression expression
))
237 (defmethod expression-precedence ((form op-form
))
238 (op-precedence (operator form
)))
240 (defmethod js-to-strings ((form op-form
) start-pos
)
241 (let* ((precedence (expression-precedence form
))
243 (mapcar #'(lambda (x)
244 (let ((string-list (js-to-strings x
(+ start-pos
2))))
245 (if (>= (expression-precedence x
) precedence
)
246 (klammer string-list
)
249 (max-length (- 80 start-pos
2))
250 (op-string (format nil
"~A " (operator form
))))
251 (dwim-join value-string-lists max-length
:join-before op-string
)
254 (defmethod js-to-strings ((one-op one-op
) start-pos
)
255 (let* ((value (value one-op
))
256 (value-strings (js-to-strings value start-pos
)))
257 (when (typep value
'op-form
)
258 (setf value-strings
(klammer value-strings
)))
259 (if (one-op-pre-p one-op
)
260 (prepend-to-first value-strings
262 (append-to-last value-strings
267 (defmethod js-to-strings ((form function-call
) start-pos
)
268 (let* ((value-string-lists
269 (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
271 (max-length (- 80 start-pos
2))
272 (args (dwim-join value-string-lists max-length
273 :start
"(" :end
")" :join-after
",")))
274 (etypecase (f-function form
)
276 (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form
) (+ start-pos
2)))
278 :start
"(" :end
")" :separator
"")
282 ((or js-variable js-aref js-slot-value
)
283 (dwim-join (list (js-to-strings (f-function form
) (+ start-pos
2))
288 ;; TODO it adds superfluous newlines after each ()
289 ;; and it's nearly the same as the js-lambda case above
290 (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form
) (+ start-pos
2)))
291 max-length
:separator
"")
293 max-length
:separator
"")))))
295 (defmethod js-to-strings ((form method-call
) start-pos
)
296 (let ((object (js-to-strings (m-object form
) (+ start-pos
2))))
297 ;; TODO: this may not be the best way to add ()'s around lambdas
298 ;; probably there is or should be a more general solution working
299 ;; in other situations involving lambda's
300 (when (member (m-object form
) (list 'js-lambda
'number-literal
'js-object
'op-form
)
303 (nconc object
(list ")")))
304 (let* ((fname (dwim-join (list object
305 (list (js-translate-symbol (m-method form
))))
309 (butlast (butlast fname
))
310 (last (car (last fname
)))
311 (method-and-args (dwim-join (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
317 (ensure-no-newline-before-dot (concatenate 'string
319 (first method-and-args
))))
320 (nconc (butlast butlast
)
321 (list ensure-no-newline-before-dot
)
322 (rest method-and-args
)))))
324 ;;; optimization that gets rid of nested blocks, which have no meaningful effect
326 (defgeneric expanded-subblocks
(block)
329 (:method
((block js-block
))
330 (mapcan #'expanded-subblocks
(block-statements block
))))
332 (defun consolidate-subblocks (block)
333 (setf (block-statements block
) (expanded-subblocks block
))
337 (defmethod js-to-statement-strings ((body js-block
) start-pos
)
338 (consolidate-subblocks body
)
339 (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x
(+ start-pos
2)))
340 (block-statements body
))
343 :append-to-last
#'special-append-to-last
344 :start
(block-indent body
) :collect nil
347 (defmethod js-to-strings ((body js-block
) start-pos
)
348 (dwim-join (mapcar #'(lambda (x) (js-to-strings x
(+ start-pos
2)))
349 (block-statements body
))
351 :append-to-last
#'special-append-to-last
353 :start
(block-indent body
)))
356 (defmethod js-to-statement-strings ((body js-sub-block
) start-pos
)
357 (declare (ignore start-pos
))
358 (nconc (list "{") (call-next-method) (list "}")))
360 ;;; function definition
361 (defmethod js-to-strings ((lambda js-lambda
) start-pos
)
362 (let ((fun-header (dwim-join (mapcar #'(lambda (x)
363 (list (js-translate-symbol x
)))
364 (lambda-args lambda
))
366 :start
(function-start-string lambda
)
367 :end
") {" :join-after
","))
368 (fun-body (js-to-statement-strings (lambda-body lambda
) (+ start-pos
2))))
369 (nconc fun-header fun-body
(list "}"))))
371 (defgeneric function-start-string
(function)
372 (:documentation
"Returns the string that starts the function - this varies according to whether
373 this is a lambda or a defun"))
375 (defmethod function-start-string ((lambda js-lambda
))
378 (defmethod js-to-statement-strings ((lambda js-lambda
) start-pos
)
379 (js-to-strings lambda start-pos
))
381 (defmethod function-start-string ((defun js-defun))
382 (format nil
"function ~A(" (js-translate-symbol (defun-name defun
))))
385 (defmethod js-to-strings ((object js-object
) start-pos
)
386 (let ((value-string-lists
387 (mapcar #'(lambda (slot)
388 (let* ((slot-name (first slot
))
390 (if (typep slot-name
'script-quote
)
391 (if (symbolp (value slot-name
))
392 (format nil
"~A" (js-translate-symbol (value slot-name
)))
393 (format nil
"~A" (first (js-to-strings slot-name
0))))
394 (car (js-to-strings slot-name
0)))))
395 (dwim-join (list (js-to-strings (second slot
) (+ start-pos
4)))
397 :start
(concatenate 'string slot-string-name
" : ")
400 (max-length (- 80 start-pos
2)))
401 (dwim-join value-string-lists max-length
408 (defmethod js-to-strings ((sv js-slot-value
) start-pos
)
409 (append-to-last (if (typep (sv-object sv
) 'js-variable
)
410 (js-to-strings (sv-object sv
) start-pos
)
411 (list (format nil
"~A" (js-to-strings (sv-object sv
) start-pos
))))
412 (if (typep (sv-slot sv
) 'script-quote
)
413 (if (symbolp (value (sv-slot sv
)))
414 (format nil
".~A" (js-translate-symbol (value (sv-slot sv
))))
415 (format nil
".~A" (first (js-to-strings (sv-slot sv
) 0))))
416 (format nil
"[~A]" (first (js-to-strings (sv-slot sv
) 0))))))
419 (defmethod js-to-statement-strings ((cond js-cond
) start-pos
)
420 (loop :for body
:on
(cond-bodies cond
)
421 :for first
= (eq body
(cond-bodies cond
))
422 :for last
= (not (cdr body
))
423 :for test
:in
(cond-tests cond
)
424 :append
(if (and last
(not first
) (string= (value test
) "true"))
426 (dwim-join (list (js-to-strings test
0)) (- 80 start-pos
2)
427 :start
(if first
"if (" "else if (") :end
") {"))
428 :append
(js-to-statement-strings (car body
) (+ start-pos
2))
431 (defmethod js-to-statement-strings ((if js-if
) start-pos
)
432 (let ((if-strings (dwim-join (list (js-to-strings (if-test if
) 0))
436 (then-strings (js-to-statement-strings (if-then if
) (+ start-pos
2)))
437 (else-strings (when (if-else if
)
438 (js-to-statement-strings (if-else if
)
440 (nconc if-strings then-strings
(if else-strings
441 (nconc (list "} else {") else-strings
(list "}"))
444 (defmethod js-to-strings ((if js-if
) start-pos
)
445 (assert (typep (if-then if
) 'expression
))
447 (assert (typep (if-else if
) 'expression
)))
448 (dwim-join (list (append-to-last (js-to-strings (if-test if
) start-pos
) " ?")
449 (let* ((new-then (make-instance 'js-block
450 :statements
(block-statements (if-then if
))
452 (res (js-to-strings new-then start-pos
)))
453 (if (>= (expression-precedence (if-then if
))
454 (expression-precedence if
))
459 (let* ((new-else (make-instance 'js-block
460 :statements
(block-statements (if-else if
))
462 (res (js-to-strings new-else start-pos
)))
463 (if (>= (expression-precedence (if-else if
))
464 (expression-precedence if
))
472 (defmethod js-to-strings ((setf js-setf
) start-pos
)
473 (dwim-join (cons (js-to-strings (setf-lhs setf
) start-pos
)
474 (mapcar #'(lambda (x) (js-to-strings x start-pos
)) (setf-rhsides setf
)))
479 (defmethod js-to-statement-strings ((defvar js-defvar
) start-pos
)
480 (dwim-join (nconc (mapcar #'(lambda (x) (list (js-translate-symbol x
))) (var-names defvar
))
481 (when (var-value defvar
)
482 (list (js-to-strings (var-value defvar
) start-pos
))))
485 :start
"var " :end
";"))
488 (defmethod js-to-statement-strings ((for js-for
) start-pos
)
489 (let* ((init (dwim-join (mapcar #'(lambda (x)
490 (dwim-join (list (list (js-translate-symbol (first (var-names x
))))
491 (js-to-strings (var-value x
)
497 :start
"var " :join-after
","))
498 (check (js-to-strings (for-check for
) (+ start-pos
2)))
499 (steps (dwim-join (mapcar #'(lambda (x var
)
501 (list (list (js-translate-symbol (first (var-names var
))))
502 (js-to-strings x
(- start-pos
2)))
509 (header (dwim-join (list init check steps
)
511 :start
"for (" :end
") {"
513 (body (js-to-statement-strings (for-body for
) (+ start-pos
2))))
514 (nconc header body
(list "}"))))
517 (defmethod js-to-statement-strings ((fe for-each
) start-pos
)
518 (let ((header (dwim-join (list (list (js-translate-symbol (fe-name fe
)))
520 (js-to-strings (fe-value fe
) (+ start-pos
2)))
524 (body (js-to-statement-strings (fe-body fe
) (+ start-pos
2))))
525 (nconc header body
(list "}"))))
527 (defmethod js-to-statement-strings ((while js-while
) start-pos
)
528 (let ((header (dwim-join (list (js-to-strings (while-check while
) (+ start-pos
2)))
532 (body (js-to-statement-strings (while-body while
) (+ start-pos
2))))
533 (nconc header body
(list "}"))))
536 (defmethod js-to-statement-strings ((with js-with
) start-pos
)
537 (nconc (dwim-join (list (js-to-strings (with-obj with
) (+ start-pos
2)))
539 :start
"with (" :end
") {")
540 (js-to-statement-strings (with-body with
) (+ start-pos
2))
544 (defmethod js-to-statement-strings ((case js-switch
) start-pos
)
545 (let ((body (mapcan #'(lambda (clause)
546 (let ((val (car clause
))
547 (body (second clause
)))
548 (dwim-join (list (if (eql val
'default
)
550 (js-to-strings val
(+ start-pos
2)))
551 (js-to-statement-strings body
(+ start-pos
2)))
553 :start
(if (eql val
'default
) " default" " case ")
555 :join-after
":"))) (case-clauses case
))))
556 (nconc (dwim-join (list (js-to-strings (case-value case
) (+ start-pos
2)))
558 :start
"switch (" :end
") {")
563 (defmethod js-to-statement-strings ((try js-try
) start-pos
)
564 (let* ((catch (try-catch try
))
565 (finally (try-finally try
))
566 (catch-list (when catch
568 (dwim-join (list (list (js-translate-symbol (first catch
))))
572 (js-to-statement-strings (second catch
) (+ start-pos
2)))))
573 (finally-list (when finally
574 (nconc (list "} finally {")
575 (js-to-statement-strings finally
(+ start-pos
2))))))
576 (nconc (list "try {")
577 (js-to-statement-strings (try-body try
) (+ start-pos
2))
583 (defun first-slash-p (string)
584 (and (> (length string
) 0)
585 (eq (char string
0) '#\
/)))
587 (defmethod js-to-strings ((regex regex
) start-pos
)
588 (declare (ignore start-pos
))
589 (let ((slash (if (first-slash-p (value regex
)) nil
"/")))
590 (list (format nil
(concatenate 'string slash
"~A" slash
) (value regex
)))))
592 ;;; conditional compilation
593 (defmethod js-to-statement-strings ((cc cc-if
) start-pos
)
594 (nconc (list (format nil
"/*@if ~A" (cc-if-test cc
)))
595 (mapcan #'(lambda (x) (js-to-strings x start-pos
)) (cc-if-body cc
))
600 (defmethod js-to-strings ((instanceof js-instanceof
) start-pos
)
602 (list (js-to-strings (value instanceof
) (+ start-pos
2))
604 (js-to-strings (slot-value instanceof
'type
) (+ start-pos
2)))
611 ;;; single operations
612 (defmacro define-translate-js-single-op
(name &optional
(superclass 'expression
))
613 (let ((script-name (intern (concatenate 'string
"JS-" (symbol-name name
)) #.
*package
*)))
614 `(defmethod ,(if (eql superclass
'expression
)
616 'js-to-statement-strings
)
617 ((,name
,script-name
) start-pos
)
618 (dwim-join (list (js-to-strings (value ,name
) (+ start-pos
2)))
620 :start
,(concatenate 'string
(string-downcase (symbol-name name
)) " ")
623 (define-translate-js-single-op return statement
)
624 (define-translate-js-single-op throw statement
)
625 (define-translate-js-single-op delete
)
626 (define-translate-js-single-op void
)
627 (define-translate-js-single-op typeof
)
628 (define-translate-js-single-op new
)