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