src/patches.lisp

;;;; Parenscript

(in-package parenscript)

;;; async/await

(defprinter ps-js::await (x)
  (psw (string-downcase "await "))
  (print-op-argument 'ps-js::await x))

(define-trivial-special-ops await ps-js::await)

(define-statement-operator async-defun (name lambda-list &rest body)
  (multiple-value-bind (effective-args body-block docstring)
      (compile-named-function-body name lambda-list body)
    (list 'ps-js::async-defun name effective-args docstring body-block)))

(defprinter ps-js::async-defun (name args docstring body-block)
  (when docstring (print-comment docstring))
  (psw "async ")
  (print-fun-def name args body-block))

(define-expression-operator async-lambda (lambda-list &rest body)
  (multiple-value-bind (effective-args effective-body)
      (parse-extended-function lambda-list body)
    `(ps-js::async-lambda
      ,effective-args
      ,(let ((*function-block-names* ()))
         (compile-function-body effective-args effective-body)))))

(defprinter ps-js::async-lambda (args body-block)
  (psw "async ")
  (print-fun-def nil args body-block))

(cl:export 'await)
(cl:export 'async-defun)
(cl:export 'async-lambda)

;;; ES6

(define-expression-operator => (lambda-list &rest body)
  (unless (listp lambda-list)
    (setf lambda-list (list lambda-list)))
  (multiple-value-bind (effective-args effective-body)
      (parse-extended-function lambda-list body)
    `(ps-js::=>
      ,effective-args
      ,(let ((*function-block-names* ()))
         (compile-function-body effective-args effective-body)))))

(defprinter ps-js::=> (args body)
  (unless (= 1 (length args))
    (psw "("))
  (loop for (arg . remaining) on args do
       (psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
  (unless (= 1 (length args))
    (psw ")"))
  (psw " => ")
  (ps-print body))

(cl:export '=>)

;;; Actually return nothing (with no empty return)
(defvar *old-return-result-of* (function return-result-of))

(defun return-result-of (tag form)
  (if (equal form '(void))
      nil
      (funcall *old-return-result-of* tag form)))
(cl:export 'void)

;;; Bitwise stuff
;; No idea why these are not exported
(export '<<)
(export '>>)

;;;; Esrap

(in-package esrap)

(defmethod print-object :around ((condition esrap-error) stream)
  (when (not txt2web::*delivered*)
    (return-from print-object
      (call-next-method)))
  (when (or *print-escape*
            *print-readably*
            (and *print-lines* (<= *print-lines* 5)))
    (return-from print-object))

  ;; FIXME: this looks like it won't do the right thing when used as
  ;; part of a logical block.
  (if-let ((text (esrap-error-text condition))
           (position (esrap-error-position condition)))
    (labels ((safe-index (index)
               (min (max index 0) (length text)))
             (find-newline (&key (start 0) (end (length text)) (from-end t))
               (let ((start (safe-index start))
                     (end   (safe-index end)))
                 (cond
                   ((when-let ((position (position #\Newline text
                                                   :start start :end end
                                                   :from-end from-end)))
                      (1+ position)))
                   ((and from-end (zerop start))
                    start)
                   ((and (not from-end) (= end (length text)))
                    end)))))
      ;; FIXME: magic numbers
      (let* ((line       (count #\Newline text :end position))
             (column     (- position (or (find-newline :end position) 0) 1))
             (min-start  (- position 160))
             (max-end    (+ position 24))
             (line-start (or (find-newline :start min-start
                                           :end   position)
                             (safe-index min-start)))
             (start      (cond
                           ((= (safe-index min-start) line-start)
                            line-start)
                           ((find-newline :start min-start
                                          :end   (1- line-start)))
                           (t

                            line-start)))
             (end        (or (find-newline :start    position
                                           :end      max-end
                                           :from-end nil)
                             (safe-index max-end)))
             (*print-circle* nil))
        (txt2web::lformat stream :error
                (= position (length text))
                (list (subseq text start end))
                (- position line-start)
                (1+ line) (1+ column) position)))

    (format stream "~2&<text and position not available>~2%")))