src/printer.lisp

   1 (in-package #:parenscript)
   2 (in-readtable :parenscript)
   3
   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.
   8
   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.")
  12
  13 (defvar *indent-level*)
  14
  15 (defvar *psw-stream*)
  16
  17 (defun parenscript-print (form immediate?)
  18   (declare (special immediate?))
  19   (let ((*indent-level* 0)
  20         (*psw-stream* (if immediate?
  21                           *psw-stream*
  22                           (make-string-output-stream)))
  23         (%psw-accumulator ()))
  24     (declare (special %psw-accumulator))
  25     (with-standard-io-syntax
  26       (if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block
  27           (loop for (statement . remaining) on (cdr form) do
  28                (ps-print statement) (psw #\;) (when remaining (psw #\Newline)))
  29           (ps-print form)))
  30     (unless immediate?
  31       (reverse (cons (get-output-stream-string *psw-stream*) %psw-accumulator)))))
  32
  33 (defun psw (&rest objs)
  34   (dolist (obj objs)
  35     (declare (special %psw-accumulator immediate?))
  36     (typecase obj
  37       (string (write-string obj *psw-stream*))
  38       (character (write-char obj *psw-stream*))
  39       (otherwise
  40        (if immediate?
  41            (write-string (eval obj) *psw-stream*)
  42            (setf %psw-accumulator
  43                  (cons obj
  44                        (cons (get-output-stream-string *psw-stream*)
  45                              %psw-accumulator))))))))
  46
  47 (defgeneric ps-print% (js-primitive args))
  48
  49 (defmacro defprinter (js-primitive args &body body)
  50   (if (listp js-primitive)
  51       (cons 'progn (mapcar (lambda (p)
  52                              `(defprinter ,p ,args ,@body))
  53                            js-primitive))
  54       (let ((pargs (gensym)))
  55         `(defmethod ps-print% ((op (eql ',js-primitive)) ,pargs)
  56            (declare (ignorable op))
  57            (destructuring-bind ,args
  58                ,pargs
  59              ,@(loop for x in body collect
  60                     (if (or (characterp x)
  61                             (stringp x))
  62                         (list 'psw x)
  63                         x)))))))
  64
  65 (defmethod ps-print ((x null))
  66   (psw "null"))
  67
  68 (defmethod ps-print ((x (eql t)))
  69   (psw "true"))
  70
  71 (defmethod ps-print ((x (eql 'ps-js:f)))
  72   (psw "false"))
  73
  74 (defmethod ps-print ((s symbol))
  75   (if (keywordp s)
  76       (ps-print (string-downcase s))
  77       (psw (symbol-to-js-string s))))
  78
  79 (defmethod ps-print ((compiled-form cons))
  80   (ps-print% (car compiled-form) (cdr compiled-form)))
  81
  82 (defun newline-and-indent ()
  83   (if *ps-print-pretty*
  84       (progn (psw #\Newline)
  85              (loop repeat (* *indent-level* *indent-num-spaces*) do (psw #\Space)))
  86       (psw #\Space)))
  87
  88 (defun print-comment (comment-str)
  89   (when *ps-print-pretty*
  90     (let ((lines (cl-ppcre:split #\Newline comment-str)))
  91       (if (cdr lines)
  92           (progn (psw "/**") (newline-and-indent)
  93                  (dolist (x lines) (psw " * " x) (newline-and-indent))
  94                  (psw " */"))
  95           (psw "/** " comment-str " */"))
  96       (newline-and-indent))))
  97
  98 (defparameter *js-lisp-escaped-chars*
  99   '((#\' . #\')
 100     (#\\ . #\\)
 101     (#\b . #\Backspace)
 102     (#\f . #.(code-char 12))
 103     (#\n . #\Newline)
 104     (#\r . #\Return)
 105     (#\t . #\Tab)))
 106
 107 (defmethod ps-print ((char character))
 108   (ps-print (string char)))
 109
 110 (defmethod ps-print ((string string))
 111   (flet ((lisp-special-char-to-js (lisp-char)
 112            (car (rassoc lisp-char *js-lisp-escaped-chars*))))
 113     (psw *js-string-delimiter*)
 114     (loop for char across string
 115           for code = (char-code char)
 116           for special = (lisp-special-char-to-js char)
 117           do (cond (special (psw #\\) (psw special))
 118                    ((or (<= code #x1f) (>= code #x80)) (format *psw-stream* "\\u~4,'0x" code))
 119                    (t (psw char))))
 120     (psw *js-string-delimiter*)))
 121
 122 (defmethod ps-print ((number number))
 123   (format *psw-stream* (if (integerp number) "~D" "~F") number))
 124
 125 (defvar %equality-ops '(ps-js:== ps-js:!= ps-js:=== ps-js:!==))
 126
 127 (let ((precedence-table (make-hash-table :test 'eq)))
 128   (loop for level in `((ps-js:getprop ps-js:aref ps-js:new ps-js:funcall)
 129                        (ps-js:lambda) ;; you won't find this in JS books
 130                        (ps-js:++ ps-js:-- ps-js:post++ ps-js:post--)
 131                        (ps-js:! ps-js:~ ps-js:negate ps-js:typeof ps-js:delete)
 132                        (ps-js:* ps-js:/ ps-js:%)
 133                        (ps-js:-)
 134                        (ps-js:+)
 135                        (ps-js:<< ps-js:>> ps-js:>>>)
 136                        (ps-js:< ps-js:> ps-js:<= ps-js:>= ps-js:instanceof ps-js:in)
 137                        ,%equality-ops
 138                        (ps-js:&)
 139                        (ps-js:^)
 140                        (ps-js:\|)
 141                        (ps-js:&&)
 142                        (ps-js:\|\|)
 143                        (ps-js:?)
 144                        (ps-js:= ps-js:*= ps-js:/= ps-js:%= ps-js:+= ps-js:-= ps-js:<<= ps-js:>>= ps-js:>>>= ps-js:&= ps-js:^= ps-js:\|=)
 145                        (ps-js:return ps-js:throw)
 146                        (ps-js:|,|))
 147      for i from 0
 148      do (mapc (lambda (symbol)
 149                 (setf (gethash symbol precedence-table) i))
 150               level))
 151   (defun op-precedence (op)
 152     (gethash op precedence-table -1)))
 153
 154 (defun associative? (op)
 155   (member op '(ps-js:+ ps-js:* ps-js:& ps-js:&& ps-js:\| ps-js:\|\|
 156                ps-js:funcall ps-js:aref ps-js:getprop))) ;; these aren't really associative, but RPN
 157
 158 (defun parenthesize-print (ps-form)
 159   (psw #\() (ps-print ps-form) (psw #\)))
 160
 161 (defun print-op-argument (op argument)
 162   (let ((arg-op (when (listp argument) (car argument))))
 163     (if (or (< (op-precedence op) (op-precedence arg-op))
 164             (and (eq op arg-op) (not (associative? op))))
 165         (parenthesize-print argument)
 166         (ps-print argument))))
 167
 168 (defun print-op (op)
 169   (psw (string-downcase op)))
 170
 171 (defprinter (ps-js:! ps-js:~ ps-js:++ ps-js:--) (x)
 172   (print-op op) (print-op-argument op x))
 173
 174 (defprinter ps-js:negate (x)
 175   "-"(print-op-argument op x))
 176
 177 (defprinter (ps-js:delete ps-js:typeof ps-js:new ps-js:throw ps-js:return) (x)
 178   (print-op op)" "(print-op-argument op x))
 179
 180 (defprinter ps-js:post++ (x)
 181   (ps-print x)"++")
 182
 183 (defprinter ps-js:post-- (x)
 184   (ps-print x)"--")
 185
 186 (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:<=)
 187     (&rest args)
 188   (loop for (arg . remaining) on args do
 189        (print-op-argument op arg)
 190        (when remaining (format *psw-stream* " ~(~A~) " op))))
 191
 192 (defprinter (ps-js:== ps-js:!= ps-js:=== ps-js:!==) (x y)
 193   (flet ((parenthesize-equality (form)
 194            (if (and (consp form) (member (car form) %equality-ops))
 195                (parenthesize-print form)
 196                (print-op-argument op form))))
 197     (parenthesize-equality x) (format *psw-stream* " ~A " op) (parenthesize-equality y)))
 198
 199 (defprinter ps-js:aref (array &rest indices)
 200   (print-op-argument 'ps-js:aref array)
 201   (dolist (idx indices)
 202     (psw #\[) (ps-print idx) (psw #\])))
 203
 204 (defun print-comma-delimited-list (ps-forms)
 205   (loop for (form . remaining) on ps-forms do
 206         (print-op-argument 'ps-js:|,| form)
 207         (when remaining (psw ", "))))
 208
 209 (defprinter ps-js:array (&rest initial-contents)
 210   "["(print-comma-delimited-list initial-contents)"]")
 211
 212 (defprinter (ps-js:|,|) (&rest expressions)
 213   (print-comma-delimited-list expressions))
 214
 215 (defprinter ps-js:funcall (fun-designator &rest args)
 216   (print-op-argument op fun-designator)"("(print-comma-delimited-list args)")")
 217
 218 (defprinter ps-js:block (&rest statements)
 219   "{" (incf *indent-level*)
 220   (dolist (statement statements)
 221     (newline-and-indent) (ps-print statement) (psw #\;))
 222   (decf *indent-level*) (newline-and-indent)
 223   "}")
 224
 225 (defprinter ps-js:lambda (args body-block)
 226   (print-fun-def nil args body-block))
 227
 228 (defprinter ps-js:defun (name args docstring body-block)
 229   (when docstring (print-comment docstring))
 230   (print-fun-def name args body-block))
 231
 232 (defun print-fun-def (name args body)
 233   (format *psw-stream* "function ~:[~;~A~](" name (symbol-to-js-string name))
 234   (loop for (arg . remaining) on args do
 235         (psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
 236   (psw ") ")
 237   (ps-print body))
 238
 239 (defprinter ps-js:object (&rest slot-defs)
 240   "{ "(loop for ((slot-name . slot-value) . remaining) on slot-defs do
 241            (ps-print slot-name) (psw " : ") (if (and (consp slot-value) (eq 'ps-js:|,| (car slot-value)))
 242                                                 (parenthesize-print slot-value)
 243                                                 (ps-print slot-value))
 244            (when remaining (psw ", ")))" }")
 245
 246 (defprinter ps-js:getprop (obj slot)
 247   (print-op-argument op obj)"."(psw (symbol-to-js-string slot)))
 248
 249 (defprinter ps-js:if (test consequent &rest clauses)
 250   "if ("(ps-print test)") "
 251   (ps-print consequent)
 252   (loop while clauses do
 253        (ecase (car clauses)
 254          (:else-if (psw " else if (") (ps-print (cadr clauses)) (psw ") ")
 255                    (ps-print (caddr clauses))
 256                    (setf clauses (cdddr clauses)))
 257          (:else (psw " else ")
 258                 (ps-print (cadr clauses))
 259                 (return)))))
 260
 261 (defprinter ps-js:? (test then else)
 262   (print-op-argument op test) " ? "
 263   (print-op-argument op then) " : "
 264   (print-op-argument op else))
 265
 266 (defprinter ps-js:var (var-name &optional (value (values) value?) docstring)
 267   (when docstring (print-comment docstring))
 268   "var "(psw (symbol-to-js-string var-name))
 269   (when value? (psw " = ") (print-op-argument 'ps-js:= value)))
 270
 271 (defprinter ps-js:label (label statement)
 272   (psw (symbol-to-js-string label))": "(ps-print statement))
 273
 274 (defprinter (ps-js:continue ps-js:break) (&optional label)
 275   (print-op op) (when label
 276                   (psw " " (symbol-to-js-string label))))
 277
 278 ;;; iteration
 279 (defprinter ps-js:for (vars tests steps body-block)
 280   (psw "for (")
 281   (loop for ((var-name . var-init) . remaining) on vars
 282         for decl = "var " then "" do
 283         (psw decl (symbol-to-js-string var-name) " = ") (ps-print var-init) (when remaining (psw ", ")))
 284   "; "
 285   (loop for (test . remaining) on tests do
 286        (ps-print test) (when remaining (psw ", ")))
 287   "; "
 288   (loop for (step . remaining) on steps do
 289        (ps-print step) (when remaining (psw ", ")))
 290   ") "
 291   (ps-print body-block))
 292
 293 (defprinter ps-js:for-in (var object body-block)
 294   "for (var "(ps-print var)" in "(ps-print object)") "
 295   (ps-print body-block))
 296
 297 (defprinter (ps-js:with ps-js:while) (expression body-block)
 298   (print-op op)" ("(ps-print expression)") "
 299   (ps-print body-block))
 300
 301 (defprinter ps-js:switch (test &rest clauses)
 302   "switch ("(ps-print test)") {"
 303   (flet ((print-body-statements (body-statements)
 304            (incf *indent-level*)
 305            (loop for statement in body-statements do
 306                 (progn (newline-and-indent)
 307                        (ps-print statement)
 308                        (psw #\;)))
 309            (decf *indent-level*)))
 310     (loop for (val . statements) in clauses
 311        do (progn (newline-and-indent)
 312                  (if (eq val 'ps-js:default)
 313                      (progn (psw "default:")
 314                             (print-body-statements statements))
 315                      (progn (psw "case ") (ps-print val) (psw #\:)
 316                             (print-body-statements statements))))))
 317   (newline-and-indent)
 318   "}")
 319
 320 (defprinter ps-js:try (body-block &key catch finally)
 321   "try "(ps-print body-block)
 322   (when catch
 323     (psw " catch ("(symbol-to-js-string (first catch))") ")
 324     (ps-print (second catch)))
 325   (when finally
 326     (psw " finally ") (ps-print finally)))
 327
 328 (defprinter ps-js:regex (regex)
 329   (let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/")))
 330     (psw (concatenate 'string slash regex slash))))
 331
 332 (defprinter ps-js:instanceof (value type)
 333   "("(print-op-argument op value)" instanceof "(print-op-argument op type)")")
 334
 335 (defprinter ps-js:escape (literal-js)
 336   ;; literal-js should be a form that evaluates to a string containing
 337   ;; valid JavaScript
 338   (psw literal-js))