src/printer.lisp

   1 (in-package :parenscript)
   2
   3 (defvar *ps-output-stream*)
   4 (defparameter *indent-level* 0)
   5
   6 (defmethod parenscript-print (ps-form &optional *ps-output-stream*)
   7   (setf *indent-level* 0)
   8   (flet ((print-ps (form)
   9            (if (and (listp form) (eql 'js-block (car form))) ;; ignore top-level block
  10                (loop for (statement . remaining) on (third form) do
  11                      (ps-print statement) (psw ";") (when remaining (psw #\Newline)))
  12                (ps-print form))))
  13     (if *ps-output-stream*
  14         (print-ps ps-form)
  15         (with-output-to-string (*ps-output-stream*)
  16           (print-ps ps-form)))))
  17
  18 (defun psw (obj) ;; parenscript-write
  19   (princ obj *ps-output-stream*))
  20
  21 (defgeneric ps-print% (special-form-name special-form-args))
  22
  23 (defmacro defprinter (special-form content-args &body body)
  24   "Given a special-form name and a destructuring lambda-list for its
  25 arguments, defines a printer for that form using the given body."
  26   (let ((sf (gensym))
  27         (sf-args (gensym)))
  28     `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args)
  29       (declare (ignorable ,sf))
  30       (destructuring-bind ,content-args
  31           ,sf-args
  32         ,@body))))
  33
  34 (defgeneric ps-print (compiled-form))
  35
  36 (defmethod ps-print ((form null)) ;; don't print top-level nils (ex: result of defining macros, etc.)
  37   )
  38
  39 (defmethod ps-print ((compiled-form cons))
  40   "Prints the given compiled ParenScript form starting at the given
  41 indent position."
  42   (ps-print% (car compiled-form) (cdr compiled-form)))
  43
  44 ;;; indentation
  45 (defvar *ps-print-pretty* t)
  46 (defvar *indent-num-spaces* 4)
  47
  48 (defun newline-and-indent ()
  49   (when (and (fresh-line *ps-output-stream*) *ps-print-pretty*)
  50     (loop repeat (* *indent-level* *indent-num-spaces*)
  51           do (psw #\Space))))
  52
  53 ;;; string literals
  54 (defvar *js-string-delimiter* #\'
  55   "Specifies which character should be used for delimiting strings.
  56
  57 This variable is used when you want to embed the resulting JavaScript
  58 in an html attribute delimited by #\\\" as opposed to #\\', or
  59 vice-versa.")
  60
  61 (defparameter *js-lisp-escaped-chars*
  62   '((#\' . #\')
  63     (#\\ . #\\)
  64     (#\b . #\Backspace)
  65     (#\f . #.(code-char 12))
  66     (#\n . #\Newline)
  67     (#\r . #\Return)
  68     (#\t . #\Tab)))
  69
  70 (defmethod ps-print ((string string))
  71   (flet ((lisp-special-char-to-js (lisp-char)
  72            (car (rassoc lisp-char *js-lisp-escaped-chars*))))
  73     (psw *js-string-delimiter*)
  74     (loop for char across string
  75           for code = (char-code char)
  76           for special = (lisp-special-char-to-js char)
  77           do (cond (special (psw #\\) (psw special))
  78                    ((or (<= code #x1f) (>= code #x80))
  79                     (format *ps-output-stream* "\\u~4,'0x" code))
  80                    (t (psw char))))
  81     (psw *js-string-delimiter*)))
  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       (psw "null")
 134       (error "Cannot translate quoted value ~S to javascript" val)))
 135
 136 (defprinter js-literal (str)
 137   (psw str))
 138
 139 (defun print-comma-delimited-list (ps-forms)
 140   (loop for (form . remaining) on ps-forms do
 141         (ps-print form) (when remaining (psw ", "))))
 142
 143 (defprinter array-literal (&rest initial-contents)
 144   (psw #\[) (print-comma-delimited-list initial-contents) (psw #\]))
 145
 146 (defprinter js-aref (array indices)
 147   (ps-print array)
 148   (loop for idx in indices do
 149         (psw #\[) (ps-print idx) (psw #\])))
 150
 151 (defprinter object-literal (&rest slot-definitions)
 152   (psw #\{)
 153   (loop for ((key . value) . remaining) on slot-definitions do
 154         (format *ps-output-stream* "~A: " (js-translate-symbol key))
 155         (ps-print value)
 156         (when remaining (psw ", ")))
 157   (psw " }"))
 158
 159 (defprinter js-variable (var)
 160   (psw (js-translate-symbol var)))
 161
 162 ;;; arithmetic operators
 163 (defun script-convert-op-name (op)
 164   (case op
 165     (and '\&\&)
 166     (or '\|\|)
 167     (not '!)
 168     (eql '\=\=)
 169     (=   '\=\=)
 170     (t op)))
 171
 172 (defun parenthesize-print (ps-form)
 173   (psw #\() (ps-print ps-form) (psw #\)))
 174
 175 (defprinter operator (op args)
 176   (loop for (arg . remaining) on args
 177         with precedence = (op-precedence op) do
 178         (if (>= (expression-precedence arg) precedence)
 179             (parenthesize-print arg)
 180             (ps-print arg))
 181         (when remaining (format *ps-output-stream* " ~A " op))))
 182
 183 (defprinter unary-operator (op arg &key prefix)
 184   (when prefix (psw op))
 185   (if (and (listp arg) (eql 'operator (car arg)))
 186       (parenthesize-print arg)
 187       (ps-print arg))
 188   (unless prefix (psw op)))
 189
 190 ;;; function and method calls
 191 (defprinter js-funcall (fun-designator args)
 192   (cond ((member (car fun-designator) '(js-variable js-aref js-slot-value))
 193          (ps-print fun-designator))
 194         ((eql 'js-lambda (car fun-designator))
 195          (psw #\() (ps-print fun-designator) (psw #\)))
 196         ((eql 'js-funcall (car fun-designator))
 197          (ps-print fun-designator)))
 198   (psw #\() (print-comma-delimited-list args) (psw #\)))
 199
 200 (defprinter js-method-call (method object args)
 201   ;; TODO: this may not be the best way to add ()'s around lambdas
 202   ;; probably there is or should be a more general solution working
 203   ;; in other situations involving lambdas
 204   (if (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator js-expression-if))))
 205       (parenthesize-print object)
 206       (ps-print object))
 207   (psw (js-translate-symbol method))
 208   (psw #\() (print-comma-delimited-list args) (psw #\)))
 209
 210 (defprinter js-block (block-type statements)
 211   (case block-type
 212     (:statement
 213      (psw #\{)
 214      (incf *indent-level*)
 215      (dolist (statement statements)
 216        (newline-and-indent) (ps-print statement) (psw #\;))
 217      (decf *indent-level*)
 218      (newline-and-indent)
 219      (psw #\}))
 220     (:expression
 221      (psw #\()
 222      (loop for (statement . remaining) on statements do
 223            (ps-print statement) (when remaining (psw ", ")))
 224      (psw #\)))))
 225
 226 (defprinter js-lambda (args body)
 227   (print-fun-def nil args body))
 228
 229 (defprinter js-defun (name args body)
 230   (print-fun-def name args body))
 231
 232 (defun print-fun-def (name args body-block)
 233   (format *ps-output-stream* "function ~:[~;~A~](" name (js-translate-symbol name))
 234   (loop for (arg . remaining) on args do
 235         (psw (js-translate-symbol arg)) (when remaining (psw ", ")))
 236   (psw ") ")
 237   (ps-print body-block))
 238
 239 ;;; object literals
 240 (defprinter js-object (slot-defs)
 241   (psw "{ ")
 242   (loop for ((slot-name slot-value) . remaining) on slot-defs do
 243         (if (and (listp slot-name) (eql 'script-quote (car slot-name)) (symbolp (second slot-name)))
 244             (psw (js-translate-symbol (second slot-name)))
 245             (ps-print slot-name))
 246         (psw " : ")
 247         (ps-print slot-value)
 248         (when remaining (psw ", ")))
 249   (psw " }"))
 250
 251 (defprinter js-slot-value (obj slot)
 252   (if (and (listp obj) (member (car obj) '(js-expression-if)))
 253       (parenthesize-print obj)
 254       (ps-print obj))
 255   (if (and (listp slot) (eql 'script-quote (car slot)))
 256       (progn (psw #\.)
 257              (if (symbolp (second slot))
 258                  (psw (js-translate-symbol (second slot)))
 259                  (ps-print slot)))
 260       (progn (psw #\[) (ps-print slot) (psw #\]))))
 261
 262 (defprinter js-cond-statement (clauses)
 263   (loop for (test body-block) in clauses
 264         for start = "if (" then " else if (" do
 265         (if (equalp test "true")
 266             (psw " else ")
 267             (progn (psw start)
 268                    (ps-print test)
 269                    (psw ") ")))
 270         (ps-print body-block)))
 271
 272 (defprinter js-statement-if (test then-block else-block)
 273   (psw "if (") (ps-print test) (psw ") ")
 274   (ps-print then-block)
 275   (when else-block
 276       (psw " else ")
 277       (ps-print else-block)))
 278
 279 (defprinter js-expression-if (test then else)
 280   (ps-print test)
 281   (psw " ? ")
 282   (if (>= (expression-precedence then) (op-precedence 'js-expression-if))
 283       (parenthesize-print then)
 284       (ps-print then))
 285   (psw " : ")
 286   (if (>= (expression-precedence else) (op-precedence 'js-expression-if))
 287       (parenthesize-print else)
 288       (ps-print else)))
 289
 290 (defprinter js-assign (lhs rhs)
 291   (ps-print lhs) (psw " = ") (ps-print rhs))
 292
 293 (defprinter js-var (var-name &rest var-value)
 294   (psw "var ")
 295   (psw (js-translate-symbol var-name))
 296   (when var-value
 297     (psw " = ")
 298     (ps-print (car var-value))))
 299
 300 (defprinter js-break (&optional label)
 301   (psw "break")
 302   (when label
 303     (psw " ")
 304     (psw (js-translate-symbol label))))
 305
 306 (defprinter js-continue (&optional label)
 307   (psw "continue")
 308   (when label
 309     (psw " ")
 310     (psw (js-translate-symbol label))))
 311
 312 ;;; iteration
 313 (defprinter js-for (label vars tests steps body-block)
 314   (when label (psw (js-translate-symbol label)) (psw ": ") (newline-and-indent))
 315   (psw "for (")
 316   (loop for ((var-name . var-init) . remaining) on vars
 317         for decl = "var " then "" do
 318         (psw decl) (psw (js-translate-symbol var-name)) (psw " = ") (ps-print var-init) (when remaining (psw ", ")))
 319   (psw "; ")
 320   (loop for (test . remaining) on tests do
 321        (ps-print test) (when remaining (psw ", ")))
 322   (psw "; ")
 323   (loop for (step . remaining) on steps do
 324        (ps-print step) (when remaining (psw ", ")))
 325   (psw ") ")
 326   (ps-print body-block))
 327
 328 (defprinter js-for-in (var object body-block)
 329   (psw "for (") (ps-print var) (psw " in ") (ps-print object) (psw ") ")
 330   (ps-print body-block))
 331
 332 (defprinter js-while (test body-block)
 333   (psw "while (") (ps-print test) (psw ") ")
 334   (ps-print body-block))
 335
 336 (defprinter js-with (expression body-block)
 337   (psw "with (") (ps-print expression) (psw ") ")
 338   (ps-print body-block))
 339
 340 (defprinter js-switch (test clauses)
 341   (flet ((print-body-statements (body-statements)
 342            (incf *indent-level*)
 343            (loop for statement in body-statements do
 344                  (progn (newline-and-indent)
 345                         (ps-print statement)
 346                         (psw #\;)))
 347            (decf *indent-level*)))
 348     (psw "switch (") (ps-print test) (psw ") {")
 349     (loop for (val . statements) in clauses
 350           do (progn (newline-and-indent)
 351                     (if (eql val 'default)
 352                         (progn (psw "default: ")
 353                                (print-body-statements statements))
 354                         (progn (psw "case ")
 355                                (ps-print val)
 356                                (psw #\:)
 357                                (print-body-statements statements)))))
 358     (newline-and-indent)
 359     (psw #\})))
 360
 361 (defprinter js-try (body-block &key catch finally)
 362   (psw "try ")
 363   (ps-print body-block)
 364   (when catch
 365     (psw " catch (") (psw (js-translate-symbol (first catch))) (psw ") ")
 366     (ps-print (second catch)))
 367   (when finally
 368     (psw " finally ")
 369     (ps-print finally)))
 370
 371 ;;; regex
 372 (defprinter js-regex (regex)
 373   (flet ((first-slash-p (string)
 374            (and (> (length string) 0) (char= (char string 0) #\/))))
 375     (let ((slash (unless (first-slash-p regex) "/")))
 376       (format *ps-output-stream* (concatenate 'string slash "~A" slash) regex))))
 377
 378 (defprinter js-return (value)
 379   (psw "return ") (ps-print value))
 380
 381 ;;; conditional compilation
 382 (defprinter cc-if (test body-forms)
 383   (psw "/*@if ")
 384   (ps-print test)
 385   (incf *indent-level*)
 386   (dolist (form body-forms)
 387     (newline-and-indent) (ps-print form) (psw #\;))
 388   (decf *indent-level*)
 389   (newline-and-indent)
 390   (psw "@end @*/"))
 391
 392 (defprinter js-instanceof (value type)
 393   (psw #\() (ps-print value) (psw " instanceof ") (ps-print type) (psw #\)))
 394
 395 (defprinter js-named-operator (op value)
 396   (format *ps-output-stream* "~(~A~) " op)
 397   (ps-print value))