src/printer.lisp

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