1 (in-package #:parenscript
)
2 (in-readtable :parenscript
)
4 (defvar *ps-print-pretty
* t
)
5 (defvar *indent-num-spaces
* 4)
6 (defvar *js-string-delimiter
* #\'
7 "Specifies which character should be used for delimiting strings.
9 This variable is used when you want to embed the resulting JavaScript
10 in an html attribute delimited by #\\\" as opposed to #\\', or
13 (defvar *indent-level
*)
18 (defvar %printer-toplevel?
)
20 (defun parenscript-print (form immediate?
)
21 (declare (special immediate?
))
22 (let ((*indent-level
* 0)
24 (*psw-stream
* (if immediate?
26 (make-string-output-stream)))
28 (%printer-toplevel? t
))
29 (declare (special %psw-accumulator
))
30 (with-standard-io-syntax
31 (if (and (listp form
) (eq 'ps-js
:block
(car form
))) ; ignore top-level block
32 (loop for
(statement . remaining
) on
(cdr form
) do
33 (ps-print statement
) (psw #\
;) (when remaining (psw #\Newline)))
36 (reverse (cons (get-output-stream-string *psw-stream
*)
39 (defun psw (&rest objs
)
41 (declare (special %psw-accumulator immediate?
))
44 (incf *column
* (length obj
))
45 (write-string obj
*psw-stream
*))
47 (if (eql obj
#\Newline
)
50 (write-char obj
*psw-stream
*))
53 (let ((str (eval obj
)))
54 (incf *column
* (length str
))
55 (write-string str
*psw-stream
*))
56 (setf %psw-accumulator
58 (get-output-stream-string *psw-stream
*)
59 %psw-accumulator
)))))))
61 (defgeneric ps-print
(form))
62 (defgeneric ps-print%
(js-primitive args
))
64 (defmethod ps-print :after
(form)
65 (declare (ignore form
))
66 (setf %printer-toplevel? nil
))
68 (defmacro defprinter
(js-primitive args
&body body
)
69 (if (listp js-primitive
)
70 (cons 'progn
(mapcar (lambda (p)
71 `(defprinter ,p
,args
,@body
))
73 (let ((pargs (gensym)))
74 `(defmethod ps-print%
((op (eql ',js-primitive
)) ,pargs
)
75 (declare (ignorable op
))
76 (destructuring-bind ,args
78 ,@(loop for x in body collect
79 (if (or (characterp x
)
84 (defmethod ps-print ((x null
))
87 (defmethod ps-print ((x (eql t
)))
90 (defmethod ps-print ((x (eql 'ps-js
:false
)))
93 (defmethod ps-print ((s symbol
))
95 (ps-print (string-downcase s
))
96 (psw (symbol-to-js-string s
))))
98 (defmethod ps-print ((compiled-form cons
))
99 (ps-print%
(car compiled-form
) (cdr compiled-form
)))
101 (defun newline-and-indent (&optional indent-spaces
)
102 (if *ps-print-pretty
*
103 (progn (psw #\Newline
)
104 (loop repeat
(if indent-spaces
106 (* *indent-level
* *indent-num-spaces
*))
110 (defun print-comment (comment-str)
111 (when *ps-print-pretty
*
112 (let ((lines (cl-ppcre:split
#\Newline comment-str
)))
114 (progn (psw "/**") (newline-and-indent)
115 (dolist (x lines
) (psw " * " x
) (newline-and-indent))
117 (psw "/** " comment-str
" */"))
118 (newline-and-indent))))
120 (defparameter *js-lisp-escaped-chars
*
124 (#\f .
#.
(code-char 12))
129 (defmethod ps-print ((char character
))
130 (ps-print (string char
)))
132 (defmethod ps-print ((string string
))
133 (flet ((lisp-special-char-to-js (lisp-char)
134 (car (rassoc lisp-char
*js-lisp-escaped-chars
*))))
135 (psw *js-string-delimiter
*)
136 (loop for char across string
137 for code
= (char-code char
)
138 for special
= (lisp-special-char-to-js char
)
139 do
(cond (special (psw #\\) (psw special
))
140 ((or (<= code
#x1f
) (>= code
#x80
))
141 (format *psw-stream
* "\\u~:@(~4,'0x~)" code
))
143 (psw *js-string-delimiter
*)))
145 (defmethod ps-print ((number number
))
146 (format *psw-stream
* (if (integerp number
) "~D" "~F") number
))
148 (defvar %equality-ops
'(ps-js:== ps-js
:!= ps-js
:=== ps-js
:!==))
150 (let ((precedence-table (make-hash-table :test
'eq
)))
151 (loop for level in
`((ps-js:getprop ps-js
:aref ps-js
:funcall
)
153 (ps-js:lambda
) ;; you won't find this in JS books
154 (ps-js:++ ps-js
:-- ps-js
:post
++ ps-js
:post--
)
155 (ps-js:! ps-js
:~ ps-js
:negate ps-js
:typeof ps-js
:delete
)
156 (ps-js:* ps-js
:/ ps-js
:%
)
158 (ps-js:<< ps-js
:>> ps-js
:>>>)
159 (ps-js:< ps-js
:> ps-js
:<= ps-js
:>= ps-js
:instanceof ps-js
:in
)
167 (ps-js:= ps-js
:*= ps-js
:/= ps-js
:%
= ps-js
:+= ps-js
:-
= ps-js
:<<= ps-js
:>>= ps-js
:>>>= ps-js
:&= ps-js
:^
= ps-js
:\|
=)
168 (ps-js:return ps-js
:throw
)
171 do
(mapc (lambda (symbol)
172 (setf (gethash symbol precedence-table
) i
))
174 (defun precedence (op)
175 (gethash op precedence-table -
1)))
177 (defun associative?
(op)
178 (member op
'(ps-js:* ps-js
:& ps-js
:&& ps-js
:\| ps-js
:\|\|
179 ps-js
:funcall ps-js
:aref ps-js
:getprop
))) ;; these aren't really associative, but RPN
181 (defun parenthesize-print (x)
182 (psw #\
() (if (functionp x
) (funcall x
) (ps-print x
)) (psw #\
)))
184 (defun parenthesize-at-toplevel (x)
185 (if %printer-toplevel?
186 (parenthesize-print x
)
189 (defun print-op-argument (op argument
)
190 (setf %printer-toplevel? nil
)
191 (let ((arg-op (when (listp argument
) (car argument
))))
192 (if (or (< (precedence op
) (precedence arg-op
))
193 (and (= (precedence op
) (precedence arg-op
))
194 (or (not (associative? op
)) (not (associative? arg-op
)))))
195 (parenthesize-print argument
)
196 (ps-print argument
))))
199 (psw (string-downcase op
)))
201 (defprinter (ps-js:! ps-js
:~ ps-js
:++ ps-js
:--
) (x)
202 (print-op op
) (print-op-argument op x
))
204 (defprinter ps-js
:negate
(x)
205 "-"(print-op-argument op x
))
207 (defprinter (ps-js:delete ps-js
:typeof ps-js
:new ps-js
:throw
) (x)
208 (print-op op
)" "(print-op-argument op x
))
210 (defprinter (ps-js:return
) (&optional
(x nil x?
))
213 (psw " ") (print-op-argument op x
)))
215 (defprinter ps-js
:post
++ (x)
218 (defprinter ps-js
:post--
(x)
221 (defprinter (ps-js:+ ps-js
:- ps-js
:* ps-js
:/ ps-js
:% ps-js
:&& ps-js
:\|\| ps-js
:& ps-js
:\| ps-js
:-
= ps-js
:+= ps-js
:*= ps-js
:/= ps-js
:%
= ps-js
:^ ps-js
:<< ps-js
:>> ps-js
:&= ps-js
:^
= ps-js
:\|
= ps-js
:= ps-js
:in ps-js
:> ps-js
:>= ps-js
:< ps-js
:<=)
223 (loop for
(arg . remaining
) on args do
224 (print-op-argument op arg
)
225 (when remaining
(format *psw-stream
* " ~(~A~) " op
))))
227 (defprinter (ps-js:== ps-js
:!= ps-js
:=== ps-js
:!==) (x y
)
228 (flet ((parenthesize-equality (form)
229 (if (and (consp form
) (member (car form
) %equality-ops
))
230 (parenthesize-print form
)
231 (print-op-argument op form
))))
232 (parenthesize-equality x
)
233 (format *psw-stream
* " ~A " op
)
234 (parenthesize-equality y
)))
236 (defprinter ps-js
:aref
(array &rest indices
)
237 (print-op-argument 'ps-js
:aref array
)
238 (dolist (idx indices
)
239 (psw #\
[) (ps-print idx
) (psw #\
])))
241 (defun print-comma-delimited-list (ps-forms)
242 (loop for
(form . remaining
) on ps-forms do
243 (print-op-argument 'ps-js
:|
,| form
)
244 (when remaining
(psw ", "))))
246 (defprinter ps-js
:array
(&rest initial-contents
)
247 "["(print-comma-delimited-list initial-contents
)"]")
249 (defprinter (ps-js:|
,|
) (&rest expressions
)
250 (print-comma-delimited-list expressions
))
252 (defprinter ps-js
:funcall
(fun-designator &rest args
)
253 (print-op-argument op fun-designator
)"("(print-comma-delimited-list args
)")")
255 (defprinter ps-js
:block
(&rest statements
)
256 "{" (incf *indent-level
*)
257 (dolist (statement statements
)
258 (newline-and-indent) (ps-print statement
) (psw #\
;))
259 (decf *indent-level
*) (newline-and-indent)
262 (defprinter ps-js
:lambda
(args body-block
)
263 (parenthesize-at-toplevel
264 (lambda () (print-fun-def nil args body-block
))))
266 (defprinter ps-js
:defun
(name args docstring body-block
)
267 (when docstring
(print-comment docstring
))
268 (print-fun-def name args body-block
))
270 (defun print-fun-def (name args body
)
271 (format *psw-stream
* "function ~:[~;~A~](" name
(symbol-to-js-string name
))
272 (loop for
(arg . remaining
) on args do
273 (psw (symbol-to-js-string arg
)) (when remaining
(psw ", ")))
277 (defprinter ps-js
:object
(&rest slot-defs
)
278 (parenthesize-at-toplevel
281 (let ((indent?
(< 2 (length slot-defs
)))
283 (loop for
((slot-name . slot-value
) . remaining
) on slot-defs do
284 (ps-print slot-name
) (psw " : ")
285 (if (and (consp slot-value
) (eq 'ps-js
:|
,|
(car slot-value
)))
286 (parenthesize-print slot-value
)
287 (ps-print slot-value
))
291 (newline-and-indent indent
)
294 (newline-and-indent (- indent
2))
298 (defprinter ps-js
:getprop
(obj slot
)
299 (print-op-argument op obj
)"."(psw (symbol-to-js-string slot
)))
301 (defprinter ps-js
:if
(test consequent
&rest clauses
)
302 "if (" (ps-print test
) ") "
303 (ps-print consequent
)
304 (loop while clauses do
306 (:else-if
(psw " else if (") (ps-print (cadr clauses
)) (psw ") ")
307 (ps-print (caddr clauses
))
308 (setf clauses
(cdddr clauses
)))
309 (:else
(psw " else ")
310 (ps-print (cadr clauses
))
313 (defprinter ps-js
:?
(test then else
)
314 (print-op-argument op test
) " ? "
315 (print-op-argument op then
) " : "
316 (print-op-argument op else
))
318 (defprinter ps-js
:var
(var-name &optional
(value (values) value?
) docstring
)
319 (when docstring
(print-comment docstring
))
320 "var "(psw (symbol-to-js-string var-name
))
321 (when value?
(psw " = ") (print-op-argument 'ps-js
:= value
)))
323 (defprinter ps-js
:label
(label statement
)
324 (psw (symbol-to-js-string label
))": "(ps-print statement
))
326 (defprinter (ps-js:continue ps-js
:break
) (&optional label
)
327 (print-op op
) (when label
328 (psw " " (symbol-to-js-string label
))))
331 (defprinter ps-js
:for
(vars tests steps body-block
)
333 (loop for
((var-name . var-init
) . remaining
) on vars
334 for decl
= "var " then
"" do
335 (psw decl
(symbol-to-js-string var-name
) " = ") (ps-print var-init
)
336 (when remaining
(psw ", ")))
338 (loop for
(test . remaining
) on tests do
339 (ps-print test
) (when remaining
(psw ", ")))
341 (loop for
(step . remaining
) on steps do
342 (ps-print step
) (when remaining
(psw ", ")))
344 (ps-print body-block
))
346 (defprinter ps-js
:for-in
(var object body-block
)
347 "for (var "(ps-print var
)" in "(ps-print object
)") "
348 (ps-print body-block
))
350 (defprinter (ps-js:with ps-js
:while
) (expression body-block
)
351 (print-op op
)" ("(ps-print expression
)") "
352 (ps-print body-block
))
354 (defprinter ps-js
:switch
(test &rest clauses
)
355 "switch ("(ps-print test
)") {"
356 (flet ((print-body-statements (body-statements)
357 (incf *indent-level
*)
358 (loop for statement in body-statements do
359 (progn (newline-and-indent)
362 (decf *indent-level
*)))
363 (loop for
(val . statements
) in clauses
364 do
(progn (newline-and-indent)
365 (if (eq val
'ps-js
:default
)
366 (progn (psw "default:")
367 (print-body-statements statements
))
368 (progn (psw "case ") (ps-print val
) (psw #\
:)
369 (print-body-statements statements
))))))
373 (defprinter ps-js
:try
(body-block &key catch finally
)
374 "try "(ps-print body-block
)
376 (psw " catch ("(symbol-to-js-string (first catch
))") ")
377 (ps-print (second catch
)))
379 (psw " finally ") (ps-print finally
)))
381 (defprinter ps-js
:regex
(regex)
382 (let ((slash (unless (and (> (length regex
) 0) (char= (char regex
0) #\
/)) "/")))
383 (psw (concatenate 'string slash regex slash
))))
385 (defprinter ps-js
:instanceof
(value type
)
386 "("(print-op-argument op value
)" instanceof "(print-op-argument op type
)")")
388 (defprinter ps-js
:escape
(literal-js)
389 ;; literal-js should be a form that evaluates to a string containing