|
|
|
|
|
(in-package sugar-qsp)
|
|
|
|
|
|
(defun entry-point-no-args ()
|
|
|
(entry-point uiop:*command-line-arguments*))
|
|
|
|
|
|
(defun entry-point (args)
|
|
|
(catch :terminate
|
|
|
(let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
|
|
|
(write-compiled-file compiler)))
|
|
|
(values))
|
|
|
|
|
|
(defun parse-opts (args)
|
|
|
(let ((mode :source)
|
|
|
(data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
|
|
|
(loop :for arg :in args
|
|
|
:do (alexandria:switch (arg :test #'string=)
|
|
|
("-o" (setf mode :target))
|
|
|
("--js" (setf mode :js))
|
|
|
("--css" (setf mode :css))
|
|
|
("--body" (setf mode :body))
|
|
|
("-c" (setf (getf data :compile) t))
|
|
|
("--beautify" (setf (getf data :beautify) t))
|
|
|
(t (push arg (getf data mode)))))
|
|
|
(unless (= 1 (length (getf data :source)))
|
|
|
(print-usage)
|
|
|
(report-error "There should be exactly one source"))
|
|
|
(unless (> 1 (length (getf data :target)))
|
|
|
(print-usage)
|
|
|
(report-error "There should be no more than one target"))
|
|
|
(unless (> 1 (length (getf data :body)))
|
|
|
(print-usage)
|
|
|
(report-error "There should be no more than one body"))
|
|
|
(unless (getf data :target)
|
|
|
(setf (getf data :target)
|
|
|
(let* ((source (first (getf data :source)))
|
|
|
(tokens (uiop:split-string source :separator "."))
|
|
|
(target (format nil "~{~A~^.~}.html"
|
|
|
(butlast tokens))))
|
|
|
(list target))))
|
|
|
(list :source (first (getf data :source))
|
|
|
:target (first (getf data :target))
|
|
|
:js (getf data :js)
|
|
|
:css (getf data :css)
|
|
|
:body (first (getf data :body))
|
|
|
:compile (getf data :compile)
|
|
|
:beautify (getf data :beautify))))
|
|
|
|
|
|
(defun print-usage ()
|
|
|
(format t "USAGE: "))
|
|
|
|
|
|
(defun parse-file (filename)
|
|
|
(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))
|
|
|
|
|
|
;;; JS
|
|
|
|
|
|
(defmethod js-sources ((compiler compiler))
|
|
|
(format nil "~{~A~^~%~%~}" (reverse (js compiler))))
|
|
|
|
|
|
;;; CSS
|
|
|
|
|
|
(defmethod css-sources ((compiler compiler))
|
|
|
(format nil "~{~A~^~%~%~}" (css compiler)))
|
|
|
|
|
|
;;; HTML
|
|
|
|
|
|
(defmethod html-sources ((compiler compiler))
|
|
|
(let ((flute:*escape-html* nil)
|
|
|
(body-template (body compiler))
|
|
|
(js (js-sources compiler))
|
|
|
(css (css-sources compiler)))
|
|
|
(with-output-to-string (out)
|
|
|
(write
|
|
|
(flute:h
|
|
|
(html
|
|
|
(head
|
|
|
(title "SugarQSP"))
|
|
|
(body
|
|
|
body-template
|
|
|
(style css)
|
|
|
(script (preprocess-js js (beautify compiler))))))
|
|
|
:stream out
|
|
|
:pretty nil))))
|
|
|
|
|
|
(defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
|
|
|
(call-next-method)
|
|
|
(with-slots (body css js)
|
|
|
compiler
|
|
|
;; Compile the game's JS
|
|
|
(push (make-javascript (parse-file source)) js)
|
|
|
;; Does the user need us to do anything else
|
|
|
(unless compile
|
|
|
;; Read in body
|
|
|
(when body-file
|
|
|
(setf body
|
|
|
(alexandria:read-file-into-string body-file)))
|
|
|
;; Include js files
|
|
|
(dolist (js-file js-files)
|
|
|
(push (format nil "////// Included file ~A~%~A" js-file
|
|
|
(alexandria:read-file-into-string js-file))
|
|
|
js))
|
|
|
;; Include css files
|
|
|
(dolist (css-file css-files)
|
|
|
(push (format nil "////// Included file ~A~%~A" css-file
|
|
|
(alexandria:read-file-into-string css-file))
|
|
|
css)))))
|
|
|
|
|
|
(defmethod write-compiled-file ((compiler compiler))
|
|
|
(alexandria:write-string-into-file
|
|
|
(if (compile-only compiler)
|
|
|
;; Just the JS
|
|
|
(preprocess-js (js-sources compiler) (beautify compiler))
|
|
|
;; All of it
|
|
|
(html-sources compiler))
|
|
|
(target compiler) :if-exists :supersede))
|
|
|
|