Remove cl-uglify-js

src/patches.lisp

@@ -0,0 +1,60 b''
+
+(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)
+
+(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 '=>)

TODO

@@ -1,6 +1,5 b''
 
-* Remove cl-uglify-js (no support for ES6 at all and no way to monkey-patch it reliably)
-* Use Parenscript's async/await
+* Use async/await
 * Use Parenscript's minifier
 * WAIT and MENU with async/await
 * Special locations

src/api.ps

@@ -11,7 +11,7 b''
 ;;; Utils
 
 (defm (root api make-act-html) (title img)
-  (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>"
+  (+ "<a class='qsp-act' href='#' onclick='SugarQSP.api.callAct(\"" title "\");'>"
      title
      "</a>"))
 
@@ -53,7 +53,7 b''
   (this.append-id (this.key-to-id key) "<br>" t))
 
 (defm (root api clear-id) (id)
-  (setf (ps:chain document (get-element-by-id id) inner-h-t-m-l) ""))
+  (setf (ps:inner-html (document.get-element-by-id id)) ""))
 
 (setf (root api text-escaper) (document.create-element :textarea))
 
@@ -62,17 +62,17 b''
       s
       (progn
         (setf (ps:@ (root api text-escaper) text-content) s)
-        (ps:@ (root api text-escaper) inner-h-t-m-l))))
+        (ps:inner-html (root api text-escaper)))))
 
 (defm (root api get-id) (id &optional force-html)
-  (ps:chain (document.get-element-by-id id) inner-h-t-m-l))
+  (ps:inner-html (document.get-element-by-id id)))
 
 (defm (root api set-id) (id contents &optional force-html)
-  (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) (this.prepare-contents contents force-html)))
+  (setf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html)))
 
 (defm (root api append-id) (id contents &optional force-html)
   (when contents
-    (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) (this.prepare-contents contents force-html))))
+    (incf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html))))
 
 ;;; Function calls
 
@@ -89,7 +89,12 b''
       (var result 0 :num)))
 
 (defm (root api call-loc) (name args)
-  (funcall (ps:getprop (root locs) name) args))
+  (with-frame
+      (funcall (ps:getprop (root locs) name) args)))
+
+(defm (root api call-act) (title)
+  (with-frame
+      (funcall (ps:getprop (root acts) title))))
 
 ;;; Text windows
 
@@ -140,7 +145,7 b''
   (let ((elt (document.get-element-by-id "qsp-acts")))
     (ps:for-in (title (root acts))
       (let ((obj (ps:getprop (root acts) title)))
-        (incf elt.inner-h-t-m-l (this.make-act-html title (ps:getprop obj :img)))))))
+        (incf (ps:inner-html elt) (this.make-act-html title (ps:getprop obj :img)))))))
       
 
 ;;; "Syntax"
@@ -266,20 +271,20 b''
 
 (defm (root api update-objs) ()
   (let ((elt (document.get-element-by-id "qsp-objs")))
-    (setf elt.inner-h-t-m-l "<ul>")
+    (setf (ps:inner-html elt) "<ul>")
     (loop :for obj :in (root objs)
-       :do (incf elt.inner-h-t-m-l (+ "<li>" obj)))
-    (incf elt.inner-h-t-m-l "</ul>")))
+       :do (incf (ps:inner-html elt) (+ "<li>" obj)))
+    (incf (ps:inner-html elt) "</ul>")))
 
 ;;; Menu
 
 (defm (root api menu) (menu-data)
   (let ((elt (document.get-element-by-id "qsp-dropdown"))
         (i 0))
-    (setf elt.inner-h-t-m-l "")
+    (setf (ps:inner-html elt) "")
     (loop :for item :in menu-data
        :do (incf i)
-       :do (incf elt.inner-h-t-m-l (this.make-menu-item-html i item.text item.icon item.loc)))
+       :do (incf (ps:inner-html elt) (this.make-menu-item-html i item.text item.icon item.loc)))
     (setf elt.style.display "block")))
 
 ;;; Content
@@ -344,12 +349,10 b''
                     objs (root objs)
                     loc-args args
                     msecs (- (*date.now) (root started-at))
-                    main-html (ps:@
-                               (document.get-element-by-id :qsp-main)
-                               inner-h-t-m-l)
-                    stat-html (ps:@
-                               (document.get-element-by-id :qsp-stat)
-                               inner-h-t-m-l)
+                    main-html (ps:inner-html
+                               (document.get-element-by-id :qsp-main))
+                    stat-html (ps:inner-html
+                               (document.get-element-by-id :qsp-stat))
                     next-location (root current-location))))
   (values))
 
@@ -363,9 +366,9 b''
     (setf (root started-at) (- (*date.now) (ps:@ data msecs)))
     (setf (root objs) (ps:@ data objs))
     (setf (root current-location) (ps:@ data next-location))
-    (setf (ps:@ (document.get-element-by-id :qsp-main) inner-h-t-m-l)
+    (setf (ps:inner-html (document.get-element-by-id :qsp-main))
           (ps:@ data main-html))
-    (setf (ps:@ (document.get-element-by-id :qsp-stat) inner-h-t-m-l)
+    (setf (ps:inner-html (document.get-element-by-id :qsp-stat))
           (ps:@ data stat-html))
     (this.update-objs)
     (api-call call-serv-loc "ONGLOAD")

src/class.lisp

@@ -6,16 +6,23 b''
     (uiop/pathname:merge-pathnames*
      filename
      (asdf:system-source-directory :sugar-qsp)))
-  (defun compile-ps (filename)
-    (format nil "////// Parenscript file: ~A~%~%~A"
-            (file-namestring filename) (ps:ps-compile-file filename))))
+  (defun read-code-from-string (string)
+    (with-input-from-string (in string)
+      `(progn
+         ,@(loop :for form := (read in nil :eof)
+              :until (eq form :eof)
+              :collect form))))
+  (defun load-src (filename)
+    (alexandria:read-file-into-string (src-file filename))))
 
 (defclass compiler ()
-  ((body :accessor body :initform #.(alexandria:read-file-into-string (src-file "extras/body.html")))
-   (css  :accessor css  :initform (list #.(alexandria:read-file-into-string (src-file "extras/default.css"))))
-   (js   :accessor js   :initform (list #.(compile-ps (src-file "src/intrinsics.ps"))
-                                        #.(compile-ps (src-file "src/api.ps"))
-                                        #.(compile-ps (src-file "src/main.ps"))))
+  ((body :accessor body :initform #.(load-src "extras/body.html"))
+   (css  :accessor css  :initform (list #.(load-src "extras/default.css")))
+   (js   :accessor js   :initform '#.(mapcar #'read-code-from-string
+                                             (mapcar #'load-src
+                                                     (list "src/intrinsics.ps"
+                                                           "src/api.ps"
+                                                           "src/main.ps"))))
    (compile :accessor compile-only :initarg :compile)
    (target  :accessor target :initarg :target)
    (beautify :accessor beautify :initarg :beautify)))

src/main.lisp

@@ -53,39 +53,6 b''
   (p:parse 'sugar-qsp-grammar
            (alexandria:read-file-into-string filename)))
 
-(defun make-javascript (locations)
-  (format nil "////// THE GAME STARTS HERE~%~%~{~A~^~%~%~}"
-          (mapcar #'ps:ps* locations)))
-
-(defun uglify-js::write-json-chars (quote s stream)
-  "Write JSON representations (chars or escape sequences) of
-characters in string S to STREAM.
-Monkey-patched to output plain utf-8 instead of escape-sequences."
-  (write-char quote stream)
-  (loop :for ch :across s
-     :for code := (char-code ch)
-     :with special
-     :do (cond ((eq ch quote)
-                (write-char #\\ stream) (write-char ch stream))
-               ((setq special (car (rassoc ch uglify-js::+json-lisp-escaped-chars+)))
-                (write-char #\\ stream) (write-char special stream))
-               (t
-                (write-char ch stream))))
-  (write-char quote stream))
-
-(defun preprocess-js (js beautify)
-  (if beautify
-      (cl-uglify-js:ast-gen-code
-       (cl-uglify-js:ast-squeeze
-        (parse-js:parse-js js)
-        :sequences nil)
-       :beautify t)
-      (cl-uglify-js:ast-gen-code
-       (cl-uglify-js:ast-mangle
-        (cl-uglify-js:ast-squeeze
-         (parse-js:parse-js js)))
-       :beautify nil)))
-
 (defun report-error (fmt &rest args)
   (apply #'format t fmt args)
   (throw :terminate nil))
@@ -93,7 +60,8 b' Monkey-patched to output plain utf-8 ins'
 ;;; JS
 
 (defmethod js-sources ((compiler compiler))
-  (format nil "~{~A~^~%~%~}" (reverse (js compiler))))
+  (let ((ps:*ps-print-pretty* (beautify compiler)))
+    (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
 
 ;;; CSS
 
@@ -116,7 +84,7 b' Monkey-patched to output plain utf-8 ins'
           (body
            body-template
            (style css)
-           (script (preprocess-js js (beautify compiler))))))
+           (script js))))
        :stream out
        :pretty nil))))
 
@@ -125,7 +93,7 b' Monkey-patched to output plain utf-8 ins'
   (with-slots (body css js)
       compiler
     ;; Compile the game's JS
-    (push (make-javascript (parse-file source)) js)
+    (push (list* 'progn (parse-file source)) js)
     ;; Does the user need us to do anything else
     (unless compile
       ;; Read in body

src/parser.lisp

@@ -325,7 +325,7 b''
                              (p:? (and spaces (p:~ "if"))))
   (:constant nil))
 
-(p:defrule block-act (and block-act-head (or block-act-ml block-act-sl))
+(p:defrule block-act (and block-act-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
@@ -547,7 +547,7 b''
 
 (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
                                                      "=" "<" ">" "!")
-                                         spaces? cat-expr)))
+                                         spaces? sum-expr)))
   (:function do-binop))
 
 (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr)))

src/ps-macros.lisp

@@ -46,9 +46,8 b''
        ,@(when has-labels
            '((defvar __labels)))
        ,@(if locals
-             `((with-frame
-                    (tagbody
-                       ,@body)))
+             `((tagbody
+                  ,@body))
              `((tagbody
                   ,@body))))))
 

sugar-qsp.asd

@@ -1,8 +1,10 b''
 
 (defsystem sugar-qsp
   :description "QSP compiler to monolithic HTML page"
-  :depends-on (:alexandria :esrap
-               :parenscript :parse-js :cl-uglify-js :flute)
+  :depends-on (:alexandria ;; General
+               :esrap ;; Parsing
+               :parenscript :flute ;; Codegening
+               )
   :pathname "src/"
   :serial t
   :components ((:file "package")