diff --git a/TODO b/TODO
--- a/TODO
+++ b/TODO
@@ -1,6 +1,5 @@
-* 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
diff --git a/src/api.ps b/src/api.ps
--- a/src/api.ps
+++ b/src/api.ps
@@ -11,7 +11,7 @@
;;; Utils
(defm (root api make-act-html) (title img)
- (+ ""
+ (+ ""
title
""))
@@ -53,7 +53,7 @@
(this.append-id (this.key-to-id key) "
" 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 @@
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 @@
(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 @@
(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 @@
(defm (root api update-objs) ()
(let ((elt (document.get-element-by-id "qsp-objs")))
- (setf elt.inner-h-t-m-l "
")
+ (setf (ps:inner-html elt) "")
(loop :for obj :in (root objs)
- :do (incf elt.inner-h-t-m-l (+ "- " obj)))
- (incf elt.inner-h-t-m-l "
")))
+ :do (incf (ps:inner-html elt) (+ "- " obj)))
+ (incf (ps:inner-html elt) "
")))
;;; 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 @@
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 @@
(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")
diff --git a/src/class.lisp b/src/class.lisp
--- a/src/class.lisp
+++ b/src/class.lisp
@@ -6,16 +6,23 @@
(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)))
diff --git a/src/main.lisp b/src/main.lisp
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -53,39 +53,6 @@
(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 @@ 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 @@ 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 @@ 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
diff --git a/src/parser.lisp b/src/parser.lisp
--- a/src/parser.lisp
+++ b/src/parser.lisp
@@ -325,7 +325,7 @@
(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 @@
(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)))
diff --git a/src/patches.lisp b/src/patches.lisp
new file mode 100644
--- /dev/null
+++ b/src/patches.lisp
@@ -0,0 +1,60 @@
+
+(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 '=>)
diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp
--- a/src/ps-macros.lisp
+++ b/src/ps-macros.lisp
@@ -46,9 +46,8 @@
,@(when has-labels
'((defvar __labels)))
,@(if locals
- `((with-frame
- (tagbody
- ,@body)))
+ `((tagbody
+ ,@body))
`((tagbody
,@body))))))
diff --git a/sugar-qsp.asd b/sugar-qsp.asd
--- a/sugar-qsp.asd
+++ b/sugar-qsp.asd
@@ -1,8 +1,10 @@
(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")