src/printer.lisp

   1 ;;; Copyright 2005 Manuel Odendahl
   2 ;;; Copyright 2005-2006 Edward Marco Baringer
   3 ;;; Copyright 2007-2012 Vladimir Sedach
   4 ;;; Copyright 2008 Travis Cross
   5 ;;; Copyright 2009-2013 Daniel Gackle
   6 ;;; Copyright 2010 Scott Bell
   7 ;;; Copyright 2014 Boris Smilga
   8
   9 ;;; SPDX-License-Identifier: BSD-3-Clause
  10
  11 ;;; Redistribution and use in source and binary forms, with or
  12 ;;; without modification, are permitted provided that the following
  13 ;;; conditions are met:
  14
  15 ;;; 1. Redistributions of source code must retain the above copyright
  16 ;;; notice, this list of conditions and the following disclaimer.
  17
  18 ;;; 2. Redistributions in binary form must reproduce the above
  19 ;;; copyright notice, this list of conditions and the following
  20 ;;; disclaimer in the documentation and/or other materials provided
  21 ;;; with the distribution.
  22
  23 ;;; 3. Neither the name of the copyright holder nor the names of its
  24 ;;; contributors may be used to endorse or promote products derived
  25 ;;; from this software without specific prior written permission.
  26
  27 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  28 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  29 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  30 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  32 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  33 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  34 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  35 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  36 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  37 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  38 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  39 ;;; POSSIBILITY OF SUCH DAMAGE.
  40
  41 (in-package #:parenscript)
  42 (in-readtable :parenscript)
  43
  44 (defvar *ps-print-pretty* t)
  45 (defvar *indent-num-spaces* 4)
  46 (defvar *js-string-delimiter* #\'
  47   "Specifies which character should be used for delimiting strings.
  48
  49 This variable is used when you want to embed the resulting JavaScript
  50 in an html attribute delimited by #\\\" as opposed to #\\', or
  51 vice-versa.")
  52
  53 (defvar *indent-level*)
  54 (defvar *column*)
  55
  56 (defvar *psw-stream*)
  57
  58 (defvar %printer-toplevel?)
  59
  60 (defun parenscript-print (form immediate?)
  61   (declare (special immediate?))
  62   (let ((*indent-level* 0)
  63         (*column* 0)
  64         (*psw-stream* (if immediate?
  65                           *psw-stream*
  66                           (make-string-output-stream)))
  67         (%psw-accumulator ())
  68         (%printer-toplevel? t))
  69     (declare (special %psw-accumulator))
  70     (with-standard-io-syntax
  71       (if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block
  72           (loop for (statement . remaining) on (cdr form) do
  73                 (ps-print statement) (psw #\;) (when remaining (psw #\Newline)))
  74           (ps-print form)))
  75     (unless immediate?
  76       (reverse (cons (get-output-stream-string *psw-stream*)
  77                      %psw-accumulator)))))
  78
  79 (defun psw (&rest objs)
  80   (dolist (obj objs)
  81     (declare (special %psw-accumulator immediate?))
  82     (typecase obj
  83       (string
  84        (incf *column* (length obj))
  85        (write-string obj *psw-stream*))
  86       (character
  87        (if (eql obj #\Newline)
  88            (setf *column* 0)
  89            (incf *column*))
  90        (write-char obj *psw-stream*))
  91       (otherwise
  92        (if immediate?
  93            (let ((str (eval obj)))
  94              (incf *column* (length str))
  95              (write-string str *psw-stream*))
  96            (setf %psw-accumulator
  97                  (list* obj
  98                         (get-output-stream-string *psw-stream*)
  99                         %psw-accumulator)))))))
 100
 101 (defgeneric ps-print (form))
 102 (defgeneric ps-print% (js-primitive args))
 103
 104 (defmethod ps-print :after (form)
 105   (declare (ignore form))
 106   (setf %printer-toplevel? nil))
 107
 108 (defmacro defprinter (js-primitive args &body body)
 109   (if (listp js-primitive)
 110       (cons 'progn (mapcar (lambda (p)
 111                              `(defprinter ,p ,args ,@body))
 112                            js-primitive))
 113       (let ((pargs (gensym)))
 114         `(defmethod ps-print% ((op (eql ',js-primitive)) ,pargs)
 115            (declare (ignorable op))
 116            (destructuring-bind ,args
 117                ,pargs
 118              ,@(loop for x in body collect
 119                     (if (or (characterp x)
 120                             (stringp x))
 121                         (list 'psw x)
 122                         x)))))))
 123
 124 (defmethod ps-print ((x null))
 125   (psw "null"))
 126
 127 (defmethod ps-print ((x (eql t)))
 128   (psw "true"))
 129
 130 (defmethod ps-print ((x (eql 'ps-js:false)))
 131   (psw "false"))
 132
 133 (defmethod ps-print ((s symbol))
 134   (if (keywordp s)
 135       (ps-print (string-downcase s))
 136       (psw (symbol-to-js-string s))))
 137
 138 (defmethod ps-print ((compiled-form cons))
 139   (ps-print% (car compiled-form) (cdr compiled-form)))
 140
 141 (defun newline-and-indent (&optional indent-spaces)
 142   (if *ps-print-pretty*
 143       (progn (psw #\Newline)
 144              (loop repeat (if indent-spaces
 145                               indent-spaces
 146                               (* *indent-level* *indent-num-spaces*))
 147                    do (psw #\Space)))
 148       (psw #\Space)))
 149
 150 (defun print-comment (comment-str)
 151   (when *ps-print-pretty*
 152     (let ((lines (cl-ppcre:split #\Newline comment-str)))
 153       (if (cdr lines)
 154           (progn (psw "/**") (newline-and-indent)
 155                  (dolist (x lines) (psw " * " x) (newline-and-indent))
 156                  (psw " */"))
 157           (psw "/** " comment-str " */"))
 158       (newline-and-indent))))
 159
 160 (defparameter *js-lisp-escaped-chars*
 161   (list #\'            #\'
 162         #\"            #\"
 163         #\\            #\\
 164         #\Backspace    #\b
 165         (code-char 12) #\f
 166         #\Newline      #\n
 167         #\Return       #\r
 168         #\Tab          #\t))
 169
 170 (defmethod ps-print ((char character))
 171   (ps-print (string char)))
 172
 173 (defmethod ps-print ((string string))
 174   (psw *js-string-delimiter*)
 175   (loop for char across string do
 176        (acond ((getf *js-lisp-escaped-chars* char)
 177                (psw #\\ it))
 178               ((or (<= (char-code char) #x1F)
 179                    (<= #x80 (char-code char) #x9F)
 180                    (member (char-code char) '(#xA0 #xAD #x200B #x200C)))
 181                (format *psw-stream* "\\u~:@(~4,'0x~)" (char-code char)))
 182               (t
 183                (psw char))))
 184   (psw *js-string-delimiter*))
 185
 186 (defmethod ps-print ((number number))
 187   (format *psw-stream* (if (integerp number) "~D" "~F") number))
 188
 189 (let ((precedence-table (make-hash-table :test 'eq)))
 190   (loop for level in '((ps-js:getprop ps-js:aref ps-js:funcall)
 191                        (ps-js:new)
 192                        (ps-js:lambda) ;; you won't find this in JS books
 193                        (ps-js:++ ps-js:-- ps-js:post++ ps-js:post--)
 194                        (ps-js:! ps-js:~ ps-js:negate ps-js:unary-plus ps-js:typeof ps-js:delete)
 195                        (ps-js:* ps-js:/ ps-js:%)
 196                        (ps-js:- ps-js:+)
 197                        (ps-js:<< ps-js:>> ps-js:>>>)
 198                        (ps-js:< ps-js:> ps-js:<= ps-js:>= ps-js:instanceof ps-js:in)
 199                        (ps-js:== ps-js:!= ps-js:=== ps-js:!==)
 200                        (ps-js:&)
 201                        (ps-js:^)
 202                        (ps-js:\|)
 203                        (ps-js:&&)
 204                        (ps-js:\|\|)
 205                        (ps-js:?)
 206                        (ps-js:= ps-js:*= ps-js:/= ps-js:%= ps-js:+= ps-js:-= ps-js:<<= ps-js:>>= ps-js:>>>= ps-js:&= ps-js:^= ps-js:\|=)
 207                        (ps-js:return ps-js:throw)
 208                        (ps-js:|,|))
 209      for i from 0
 210      do (mapc (lambda (symbol)
 211                 (setf (gethash symbol precedence-table) i))
 212               level))
 213   (defun precedence (op)
 214     (gethash op precedence-table -1)))
 215
 216 (defun associative? (op)
 217   (member op '(ps-js:* ps-js:& ps-js:&& ps-js:\| ps-js:\|\|
 218                ps-js:funcall ps-js:aref ps-js:getprop))) ;; these aren't really associative, but RPN
 219
 220 (defun parenthesize-print (x)
 221   (psw #\() (if (functionp x) (funcall x) (ps-print x)) (psw #\)))
 222
 223 (defun parenthesize-at-toplevel (x)
 224   (if %printer-toplevel?
 225       (parenthesize-print x)
 226       (funcall x)))
 227
 228 (defun print-op-argument (op argument)
 229   (setf %printer-toplevel? nil)
 230   (let ((arg-op (when (listp argument) (car argument))))
 231     (if (or (< (precedence op) (precedence arg-op))
 232             (and (= (precedence op) (precedence arg-op))
 233                  (or (not (associative? op)) (not (associative? arg-op)))))
 234         (parenthesize-print argument)
 235         (ps-print argument))))
 236
 237 (defun print-op (op)
 238   (psw (string-downcase op)))
 239
 240 (defprinter (ps-js:! ps-js:~ ps-js:++ ps-js:--) (x)
 241   (print-op op) (print-op-argument op x))
 242
 243 (defprinter ps-js:negate (x)
 244   "-"(print-op-argument op x))
 245
 246 (defprinter ps-js:unary-plus (x)
 247   "+"(print-op-argument op x))
 248
 249 (defprinter (ps-js:delete ps-js:typeof ps-js:new ps-js:throw) (x)
 250   (print-op op)" "(print-op-argument op x))
 251
 252 (defprinter (ps-js:return) (&optional (x nil x?))
 253   (print-op op)
 254   (when x?
 255     (psw " ") (print-op-argument op x)))
 256
 257 (defprinter ps-js:post++ (x)
 258   (ps-print x)"++")
 259
 260 (defprinter ps-js:post-- (x)
 261   (ps-print x)"--")
 262
 263 (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:<= ps-js:== ps-js:!= ps-js:=== ps-js:!==)
 264     (&rest args)
 265   (loop for (arg . remaining) on args do
 266        (print-op-argument op arg)
 267        (when remaining (format *psw-stream* " ~(~A~) " op))))
 268
 269 (defprinter ps-js:aref (array &rest indices)
 270   (print-op-argument 'ps-js:aref array)
 271   (dolist (idx indices)
 272     (psw #\[) (ps-print idx) (psw #\])))
 273
 274 (defun print-comma-delimited-list (ps-forms)
 275   (loop for (form . remaining) on ps-forms do
 276         (print-op-argument 'ps-js:|,| form)
 277         (when remaining (psw ", "))))
 278
 279 (defprinter ps-js:array (&rest initial-contents)
 280   "["(print-comma-delimited-list initial-contents)"]")
 281
 282 (defprinter (ps-js:|,|) (&rest expressions)
 283   (print-comma-delimited-list expressions))
 284
 285 (defprinter ps-js:funcall (fun-designator &rest args)
 286   (print-op-argument op fun-designator)"("(print-comma-delimited-list args)")")
 287
 288 (defprinter ps-js:block (&rest statements)
 289   "{" (incf *indent-level*)
 290   (dolist (statement statements)
 291     (newline-and-indent) (ps-print statement) (psw #\;))
 292   (decf *indent-level*) (newline-and-indent)
 293   "}")
 294
 295 (defprinter ps-js:lambda (args body-block)
 296   (parenthesize-at-toplevel
 297    (lambda () (print-fun-def nil args body-block))))
 298
 299 (defprinter ps-js:defun (name args docstring body-block)
 300   (when docstring (print-comment docstring))
 301   (print-fun-def name args body-block))
 302
 303 (defun print-fun-def (name args body)
 304   (destructuring-bind (keyword name) (if (consp name) name `(function ,name))
 305     (format *psw-stream* "~(~A~) ~:[~;~A~]("
 306             keyword name (symbol-to-js-string name))
 307     (loop for (arg . remaining) on args do
 308         (psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
 309     (psw ") ")
 310     (ps-print body)))
 311
 312 (defprinter ps-js:object (&rest slot-defs)
 313   (parenthesize-at-toplevel
 314    (lambda ()
 315      (psw "{ ")
 316      (let ((indent? (< 2 (length slot-defs)))
 317            (indent *column*))
 318        (loop for ((slot-name . slot-value) . remaining) on slot-defs do
 319             (if (consp slot-name)
 320                 (apply #'print-fun-def slot-name slot-value)
 321                 (progn
 322                   (ps-print slot-name) (psw " : ")
 323                   (if (and (consp slot-value)
 324                            (eq 'ps-js:|,| (car slot-value)))
 325                       (parenthesize-print slot-value)
 326                       (ps-print slot-value))))
 327             (when remaining
 328               (psw ",")
 329               (if indent?
 330                   (newline-and-indent indent)
 331                   (psw #\Space))))
 332        (if indent?
 333            (newline-and-indent (- indent 2))
 334            (psw #\Space)))
 335      (psw "}"))))
 336
 337 (defprinter ps-js:getprop (obj slot)
 338   (print-op-argument op obj)"."(psw (symbol-to-js-string slot)))
 339
 340 (defprinter ps-js:if (test consequent &rest clauses)
 341   "if (" (ps-print test) ") "
 342   (ps-print consequent)
 343   (loop while clauses do
 344        (ecase (car clauses)
 345          (:else-if (psw " else if (") (ps-print (cadr clauses)) (psw ") ")
 346                    (ps-print (caddr clauses))
 347                    (setf clauses (cdddr clauses)))
 348          (:else (psw " else ")
 349                 (ps-print (cadr clauses))
 350                 (return)))))
 351
 352 (defprinter ps-js:? (test then else)
 353   (print-op-argument op test) " ? "
 354   (print-op-argument op then) " : "
 355   (print-op-argument op else))
 356
 357 (defprinter ps-js:var (var-name &optional (value (values) value?) docstring)
 358   (when docstring (print-comment docstring))
 359   "var "(psw (symbol-to-js-string var-name))
 360   (when value? (psw " = ") (print-op-argument 'ps-js:= value)))
 361
 362 (defprinter ps-js:label (label statement)
 363   (psw (symbol-to-js-string label))": "(ps-print statement))
 364
 365 (defprinter (ps-js:continue ps-js:break) (&optional label)
 366   (print-op op) (when label
 367                   (psw " " (symbol-to-js-string label))))
 368
 369 ;;; iteration
 370 (defprinter ps-js:for (vars tests steps body-block)
 371   "for ("
 372   (loop for ((var-name . var-init) . remaining) on vars
 373      for decl = "var " then "" do
 374        (psw decl (symbol-to-js-string var-name) " = ")
 375        (print-op-argument 'ps-js:= var-init)
 376        (when remaining (psw ", ")))
 377   "; "
 378   (loop for (test . remaining) on tests do
 379        (ps-print test) (when remaining (psw ", ")))
 380   "; "
 381   (loop for (step . remaining) on steps do
 382        (ps-print step) (when remaining (psw ", ")))
 383   ") "
 384   (ps-print body-block))
 385
 386 (defprinter ps-js:for-in (var object body-block)
 387   "for (var "(ps-print var)" in "(ps-print object)") "
 388   (ps-print body-block))
 389
 390 (defprinter (ps-js:with ps-js:while) (expression body-block)
 391   (print-op op)" ("(ps-print expression)") "
 392   (ps-print body-block))
 393
 394 (defprinter ps-js:switch (test &rest clauses)
 395   "switch ("(ps-print test)") {"
 396   (flet ((print-body (body)
 397            (incf *indent-level*)
 398            (loop for statement in body do
 399                  (newline-and-indent)
 400                  (ps-print statement)
 401                  (psw #\;))
 402            (decf *indent-level*)))
 403     (loop for (val . statements) in clauses do
 404          (newline-and-indent)
 405          (if (eq val 'ps-js:default)
 406              (progn (psw "default:")
 407                     (print-body statements))
 408              (progn (psw "case ") (ps-print val) (psw #\:)
 409                     (print-body statements)))))
 410   (newline-and-indent)
 411   "}")
 412
 413 (defprinter ps-js:try (body-block &key catch finally)
 414   "try "(ps-print body-block)
 415   (when catch
 416     (psw " catch ("(symbol-to-js-string (first catch))") ")
 417     (ps-print (second catch)))
 418   (when finally
 419     (psw " finally ") (ps-print finally)))
 420
 421 (defprinter ps-js:regex (regex)
 422   (let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/")))
 423     (psw (concatenate 'string slash regex slash))))
 424
 425 (defprinter ps-js:instanceof (value type)
 426   "("(print-op-argument op value)" instanceof "(print-op-argument op type)")")
 427
 428 (defprinter ps-js:escape (literal-js)
 429   ;; literal-js should be a form that evaluates to a string containing
 430   ;; valid JavaScript
 431   (psw literal-js))