Clarified the behavior of CASE when it comes to symbols and fixed some other bugs...
[parenscript.git] / src / printer.lisp
blob348f55a8d647795c2f5151bf50b3d376173a3ced
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
11 vice-versa.")
13 (defvar *indent-level*)
14 (defvar *column*)
16 (defvar *psw-stream*)
18 (defvar %printer-toplevel?)
20 (defun parenscript-print (form immediate?)
21 (declare (special immediate?))
22 (let ((*indent-level* 0)
23 (*column* 0)
24 (*psw-stream* (if immediate?
25 *psw-stream*
26 (make-string-output-stream)))
27 (%psw-accumulator ())
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)))
34 (ps-print form)))
35 (unless immediate?
36 (reverse (cons (get-output-stream-string *psw-stream*)
37 %psw-accumulator)))))
39 (defun psw (&rest objs)
40 (dolist (obj objs)
41 (declare (special %psw-accumulator immediate?))
42 (typecase obj
43 (string
44 (incf *column* (length obj))
45 (write-string obj *psw-stream*))
46 (character
47 (if (eql obj #\Newline)
48 (setf *column* 0)
49 (incf *column*))
50 (write-char obj *psw-stream*))
51 (otherwise
52 (if immediate?
53 (let ((str (eval obj)))
54 (incf *column* (length str))
55 (write-string str *psw-stream*))
56 (setf %psw-accumulator
57 (list* obj
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))
72 js-primitive))
73 (let ((pargs (gensym)))
74 `(defmethod ps-print% ((op (eql ',js-primitive)) ,pargs)
75 (declare (ignorable op))
76 (destructuring-bind ,args
77 ,pargs
78 ,@(loop for x in body collect
79 (if (or (characterp x)
80 (stringp x))
81 (list 'psw x)
82 x)))))))
84 (defmethod ps-print ((x null))
85 (psw "null"))
87 (defmethod ps-print ((x (eql t)))
88 (psw "true"))
90 (defmethod ps-print ((x (eql 'ps-js:false)))
91 (psw "false"))
93 (defmethod ps-print ((s symbol))
94 (if (keywordp s)
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
105 indent-spaces
106 (* *indent-level* *indent-num-spaces*))
107 do (psw #\Space)))
108 (psw #\Space)))
110 (defun print-comment (comment-str)
111 (when *ps-print-pretty*
112 (let ((lines (cl-ppcre:split #\Newline comment-str)))
113 (if (cdr lines)
114 (progn (psw "/**") (newline-and-indent)
115 (dolist (x lines) (psw " * " x) (newline-and-indent))
116 (psw " */"))
117 (psw "/** " comment-str " */"))
118 (newline-and-indent))))
120 (defparameter *js-lisp-escaped-chars*
121 '((#\' . #\')
122 (#\\ . #\\)
123 (#\b . #\Backspace)
124 (#\f . #.(code-char 12))
125 (#\n . #\Newline)
126 (#\r . #\Return)
127 (#\t . #\Tab)))
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))
142 (t (psw char))))
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)
152 (ps-js:new)
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:%)
157 (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)
160 ,%equality-ops
161 (ps-js:&)
162 (ps-js:^)
163 (ps-js:\|)
164 (ps-js:&&)
165 (ps-js:\|\|)
166 (ps-js:?)
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)
169 (ps-js:|,|))
170 for i from 0
171 do (mapc (lambda (symbol)
172 (setf (gethash symbol precedence-table) i))
173 level))
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)
187 (funcall 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))))
198 (defun print-op (op)
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?))
211 (print-op op)
212 (when x?
213 (psw " ") (print-op-argument op x)))
215 (defprinter ps-js:post++ (x)
216 (ps-print x)"++")
218 (defprinter ps-js:post-- (x)
219 (ps-print 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:<=)
222 (&rest args)
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)
260 "}")
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 ", ")))
274 (psw ") ")
275 (ps-print body))
277 (defprinter ps-js:object (&rest slot-defs)
278 (parenthesize-at-toplevel
279 (lambda ()
280 (psw "{ ")
281 (let ((indent? (< 2 (length slot-defs)))
282 (indent *column*))
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))
288 (when remaining
289 (psw ",")
290 (if indent?
291 (newline-and-indent indent)
292 (psw #\Space))))
293 (if indent?
294 (newline-and-indent (- indent 2))
295 (psw #\Space)))
296 (psw "}"))))
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
305 (ecase (car clauses)
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))
311 (return)))))
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))))
330 ;;; iteration
331 (defprinter ps-js:for (vars tests steps body-block)
332 "for ("
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 ", ")))
337 "; "
338 (loop for (test . remaining) on tests do
339 (ps-print test) (when remaining (psw ", ")))
340 "; "
341 (loop for (step . remaining) on steps do
342 (ps-print step) (when remaining (psw ", ")))
343 ") "
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)
360 (ps-print statement)
361 (psw #\;)))
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))))))
370 (newline-and-indent)
371 "}")
373 (defprinter ps-js:try (body-block &key catch finally)
374 "try "(ps-print body-block)
375 (when catch
376 (psw " catch ("(symbol-to-js-string (first catch))") ")
377 (ps-print (second catch)))
378 (when finally
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
390 ;; valid JavaScript
391 (psw literal-js))