src/js-translation.lisp

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