src/printer.lisp

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