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