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