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