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