src/printer.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 (defvar *ps-print-pretty* t)
   4 (defvar *indent-num-spaces* 4)
   5 (defvar *js-string-delimiter* #\'
   6   "Specifies which character should be used for delimiting strings.
   7
   8 This variable is used when you want to embed the resulting JavaScript
   9 in an html attribute delimited by #\\\" as opposed to #\\', or
  10 vice-versa.")
  11
  12 (defvar *indent-level*)
  13 (defvar *print-accumulator*)
  14
  15 (defmethod parenscript-print (form)
  16   (let ((*indent-level* 0)
  17         (*print-accumulator* ()))
  18       (if (and (listp form) (eql 'js-block (car form))) ; ignore top-level block
  19           (loop for (statement . remaining) on (third form) do
  20                (ps-print statement) (psw ";") (when remaining (psw #\Newline)))
  21           (ps-print form))
  22       (nreverse *print-accumulator*)))
  23
  24 (defun psw (obj)
  25   (push (if (characterp obj) (string obj) obj) *print-accumulator*))
  26
  27 (defgeneric ps-print% (special-form-name special-form-args))
  28
  29 (defmacro defprinter (special-form content-args &body body)
  30   "Given a special-form name and a destructuring lambda-list for its
  31 arguments, defines a printer for that form using the given body."
  32   (let ((sf (gensym))
  33         (sf-args (gensym)))
  34     `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args)
  35       (declare (ignorable ,sf))
  36       (destructuring-bind ,content-args
  37           ,sf-args
  38         ,@body))))
  39
  40 (defgeneric ps-print (compiled-form))
  41
  42 (defmethod ps-print ((form null))) ; don't print top-level nils (ex: result of defining macros, etc.)
  43
  44 (defmethod ps-print ((s symbol))
  45   (assert (keywordp s))
  46   (ps-print (js-translate-symbol s)))
  47
  48 (defmethod ps-print ((compiled-form cons))
  49   (ps-print% (car compiled-form) (cdr compiled-form)))
  50
  51 (defun newline-and-indent ()
  52   (if *ps-print-pretty*
  53       (progn (psw #\Newline)
  54              (loop repeat (* *indent-level* *indent-num-spaces*) do (psw #\Space)))
  55       (psw #\Space)))
  56
  57 (defparameter *js-lisp-escaped-chars*
  58   '((#\' . #\')
  59     (#\\ . #\\)
  60     (#\b . #\Backspace)
  61     (#\f . #.(code-char 12))
  62     (#\n . #\Newline)
  63     (#\r . #\Return)
  64     (#\t . #\Tab)))
  65
  66 (defmethod ps-print ((string string))
  67   (flet ((lisp-special-char-to-js (lisp-char)
  68            (car (rassoc lisp-char *js-lisp-escaped-chars*))))
  69     (psw *js-string-delimiter*)
  70     (loop for char across string
  71           for code = (char-code char)
  72           for special = (lisp-special-char-to-js char)
  73           do (cond (special (psw #\\) (psw special))
  74                    ((or (<= code #x1f) (>= code #x80)) (psw (format nil "\\u~4,'0x" code)))
  75                    (t (psw char))))
  76     (psw *js-string-delimiter*)))
  77
  78 (defmethod ps-print ((number number))
  79   (psw (format nil (if (integerp number) "~S" "~F") number)))
  80
  81 ;;; expression and operator precedence rules
  82
  83 (defun expression-precedence (expr)
  84   (if (consp expr)
  85       (case (car expr)
  86         ((js-slot-value js-aref) (op-precedence (car expr)))
  87         (js-assign (op-precedence '=))
  88         (js:? (op-precedence 'js:?))
  89         (unary-operator (op-precedence (second expr)))
  90         (operator (op-precedence (second expr)))
  91         (otherwise 0))
  92       0))
  93
  94 (eval-when (:compile-toplevel :load-toplevel :execute)
  95   (defparameter *op-precedence-hash* (make-hash-table :test 'eq))
  96
  97   (let ((precedence 1))
  98     (dolist (ops '((new js-slot-value js-aref)
  99                    (postfix++ postfix--)
 100                    (delete void typeof ++ -- unary+ unary- ~ !)
 101                    (* / %)
 102                    (+ -)
 103                    (<< >> >>>)
 104                    (< > <= >= js-instance-of in)
 105                    (== != === !== eql)
 106                    (&)
 107                    (^)
 108                    (\|)
 109                    (\&\& and)
 110                    (\|\| or)
 111                    (js:?)
 112                    (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|= js-assign)
 113                    (comma)))
 114       (dolist (op ops)
 115         (setf (gethash op *op-precedence-hash*) precedence))
 116       (incf precedence)))
 117
 118   (defun op-precedence (op)
 119     (gethash op *op-precedence-hash*)))
 120
 121 (defprinter js-literal (str)
 122   (psw str))
 123
 124 (defun print-comma-delimited-list (ps-forms)
 125   (loop for (form . remaining) on ps-forms do
 126         (ps-print form) (when remaining (psw ", "))))
 127
 128 (defprinter array-literal (&rest initial-contents)
 129   (psw #\[) (print-comma-delimited-list initial-contents) (psw #\]))
 130
 131 (defprinter js-aref (array indices)
 132   (if (>= (expression-precedence array) #.(op-precedence 'js-aref))
 133       (parenthesize-print array)
 134       (ps-print array))
 135   (loop for idx in indices do
 136         (psw #\[) (ps-print idx) (psw #\])))
 137
 138 (defprinter js-variable (var)
 139   (psw (js-translate-symbol var)))
 140
 141 ;;; arithmetic operators
 142 (defun parenthesize-print (ps-form)
 143   (psw #\() (ps-print ps-form) (psw #\)))
 144
 145 (defprinter operator (op args)
 146   (loop for (arg . remaining) on args
 147         with precedence = (op-precedence op) do
 148         (if (>= (expression-precedence arg) precedence)
 149             (parenthesize-print arg)
 150             (ps-print arg))
 151         (when remaining (psw (format nil " ~(~A~) " op)))))
 152
 153 (defprinter unary-operator (op arg &key prefix space)
 154   (when prefix (psw (format nil "~(~a~)~:[~; ~]" op space)))
 155   (if (> (expression-precedence arg)
 156          (op-precedence (case op
 157                           (+ 'unary+)
 158                           (- 'unary-)
 159                           (t op))))
 160       (parenthesize-print arg)
 161       (ps-print arg))
 162   (unless prefix (psw (format nil "~(~a~)" op))))
 163
 164 (defprinter js-funcall (fun-designator args)
 165   (funcall (if (member (car fun-designator) '(js-variable js-aref js-slot-value js-funcall))
 166                #'ps-print
 167                #'parenthesize-print)
 168            fun-designator)
 169   (psw #\() (print-comma-delimited-list args) (psw #\)))
 170
 171 (defprinter js-block (block-type statements)
 172   (case block-type
 173     (:statement
 174      (psw #\{)
 175      (incf *indent-level*)
 176      (dolist (statement statements)
 177        (newline-and-indent) (ps-print statement) (psw #\;))
 178      (decf *indent-level*)
 179      (newline-and-indent)
 180      (psw #\}))
 181     (:expression
 182      (psw #\()
 183      (loop for (statement . remaining) on statements do
 184            (ps-print statement) (when remaining (psw ", ")))
 185      (psw #\)))))
 186
 187 (defprinter js-lambda (args body)
 188   (print-fun-def nil args body))
 189
 190 (defprinter js-defun (name args body)
 191   (print-fun-def name args body))
 192
 193 (defun print-fun-def (name args body-block)
 194   (psw (format nil "function ~:[~;~A~](" name (js-translate-symbol name)))
 195   (loop for (arg . remaining) on args do
 196         (psw (js-translate-symbol arg)) (when remaining (psw ", ")))
 197   (psw ") ")
 198   (ps-print body-block))
 199
 200 (defprinter js-object (slot-defs)
 201   (psw "{ ")
 202   (loop for ((slot-name . slot-value) . remaining) on slot-defs do
 203         (if (and (listp slot-name) (eq 'quote (car slot-name)) (symbolp (second slot-name)))
 204             (psw (js-translate-symbol (second slot-name)))
 205             (ps-print slot-name))
 206         (psw " : ")
 207         (ps-print slot-value)
 208         (when remaining (psw ", ")))
 209   (psw " }"))
 210
 211 (defprinter js-slot-value (obj slot)
 212   (if (or (> (expression-precedence obj) #.(op-precedence 'js-slot-value))
 213           (numberp obj)
 214           (and (listp obj) (member (car obj) '(js-lambda js-object))))
 215       (parenthesize-print obj)
 216       (ps-print obj))
 217   (if (symbolp slot)
 218       (progn (psw #\.) (psw (js-translate-symbol slot)))
 219       (progn (psw #\[) (ps-print slot) (psw #\]))))
 220
 221 (defprinter js-cond-statement (clauses)
 222   (loop for (test body-block) in clauses
 223         for start = "if (" then " else if (" do
 224         (if (equalp test "true")
 225             (psw " else ")
 226             (progn (psw start)
 227                    (ps-print test)
 228                    (psw ") ")))
 229         (ps-print body-block)))
 230
 231 (defprinter js:if (test then-block else-block)
 232   (psw "if (") (ps-print test) (psw ") ")
 233   (ps-print then-block)
 234   (when else-block
 235       (psw " else ")
 236       (ps-print else-block)))
 237
 238 (defprinter js:? (test then else)
 239   (ps-print test)
 240   (psw " ? ")
 241   (if (>= (expression-precedence then) (op-precedence 'js:?))
 242       (parenthesize-print then)
 243       (ps-print then))
 244   (psw " : ")
 245   (if (>= (expression-precedence else) (op-precedence 'js:?))
 246       (parenthesize-print else)
 247       (ps-print else)))
 248
 249 (defprinter js-assign (lhs rhs)
 250   (ps-print lhs) (psw " = ") (ps-print rhs))
 251
 252 (defprinter js-var (var-name &rest var-value)
 253   (psw "var ")
 254   (psw (js-translate-symbol var-name))
 255   (when var-value
 256     (psw " = ")
 257     (ps-print (car var-value))))
 258
 259 (defprinter js-break (&optional label)
 260   (psw "break")
 261   (when label
 262     (psw " ")
 263     (psw (js-translate-symbol label))))
 264
 265 (defprinter js-continue (&optional label)
 266   (psw "continue")
 267   (when label
 268     (psw " ")
 269     (psw (js-translate-symbol label))))
 270
 271 ;;; iteration
 272 (defprinter js-for (label vars tests steps body-block)
 273   (when label (psw (js-translate-symbol label)) (psw ": ") (newline-and-indent))
 274   (psw "for (")
 275   (loop for ((var-name . var-init) . remaining) on vars
 276         for decl = "var " then "" do
 277         (psw decl) (psw (js-translate-symbol var-name)) (psw " = ") (ps-print var-init) (when remaining (psw ", ")))
 278   (psw "; ")
 279   (loop for (test . remaining) on tests do
 280        (ps-print test) (when remaining (psw ", ")))
 281   (psw "; ")
 282   (loop for (step . remaining) on steps do
 283        (ps-print step) (when remaining (psw ", ")))
 284   (psw ") ")
 285   (ps-print body-block))
 286
 287 (defprinter js-for-in (var object body-block)
 288   (psw "for (") (ps-print var) (psw " in ")
 289   (if (> (expression-precedence object) (op-precedence 'in))
 290       (parenthesize-print object)
 291       (ps-print object))
 292   (psw ") ")
 293   (ps-print body-block))
 294
 295 (defprinter js-while (test body-block)
 296   (psw "while (") (ps-print test) (psw ") ")
 297   (ps-print body-block))
 298
 299 (defprinter js-with (expression body-block)
 300   (psw "with (") (ps-print expression) (psw ") ")
 301   (ps-print body-block))
 302
 303 (defprinter js-switch (test clauses)
 304   (flet ((print-body-statements (body-statements)
 305            (incf *indent-level*)
 306            (loop for statement in body-statements do
 307                  (progn (newline-and-indent)
 308                         (ps-print statement)
 309                         (psw #\;)))
 310            (decf *indent-level*)))
 311     (psw "switch (") (ps-print test) (psw ") {")
 312     (loop for (val . statements) in clauses
 313           do (progn (newline-and-indent)
 314                     (if (eq val 'default)
 315                         (progn (psw "default: ")
 316                                (print-body-statements statements))
 317                         (progn (psw "case ")
 318                                (ps-print val)
 319                                (psw #\:)
 320                                (print-body-statements statements)))))
 321     (newline-and-indent)
 322     (psw #\})))
 323
 324 (defprinter js-try (body-block &key catch finally)
 325   (psw "try ")
 326   (ps-print body-block)
 327   (when catch
 328     (psw " catch (") (psw (js-translate-symbol (first catch))) (psw ") ")
 329     (ps-print (second catch)))
 330   (when finally
 331     (psw " finally ")
 332     (ps-print finally)))
 333
 334 ;;; regex
 335 (defprinter js-regex (regex)
 336   (flet ((first-slash-p (string)
 337            (and (> (length string) 0) (char= (char string 0) #\/))))
 338     (let ((slash (unless (first-slash-p regex) "/")))
 339       (psw (format nil (concatenate 'string slash "~A" slash) regex)))))
 340
 341 ;;; conditional compilation
 342 (defprinter cc-if (test body-forms)
 343   (psw "/*@if ")
 344   (ps-print test)
 345   (incf *indent-level*)
 346   (dolist (form body-forms)
 347     (newline-and-indent) (ps-print form) (psw #\;))
 348   (decf *indent-level*)
 349   (newline-and-indent)
 350   (psw "@end @*/"))
 351
 352 (defprinter js-instanceof (value type)
 353   (psw #\()
 354   (if (> (expression-precedence value) (op-precedence 'js-instance-of))
 355       (parenthesize-print value)
 356       (ps-print value))
 357   (psw " instanceof ")
 358   (if (> (expression-precedence type) (op-precedence 'js-instance-of))
 359       (parenthesize-print type)
 360       (ps-print type))
 361   (psw #\)))
 362
 363 (defprinter js-escape (lisp-form)
 364   (psw `(ps1* ,lisp-form)))
 365
 366 ;;; named statements
 367 (macrolet ((def-stmt-printer (&rest stmts)
 368              `(progn ,@(mapcar (lambda (stmt)
 369                                  `(defprinter ,(intern (format nil "JS-~a" stmt)) (expr)
 370                                     (psw (format nil "~(~a~) " ',stmt))
 371                                     (ps-print expr)))
 372                                stmts))))
 373   (def-stmt-printer throw return))