src/main.lisp

(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 "~{~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

(defun src-file (filename)
  (uiop/pathname:merge-pathnames*
   filename
   (asdf:system-source-directory :sugar-qsp)))

(defmethod js-sources ((compiler compiler))
  (format nil "~{~A~^~%~%~}" (reverse (js compiler))))

(defun compile-ps (filename)
  (format nil "////// Parenscript file: ~A~%~%~A"
          (file-namestring filename) (ps:ps-compile-file filename)))

;;; 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))))

(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"))))
   (compile :accessor compile-only :initarg :compile)
   (target  :accessor target :initarg :target)
   (beautify :accessor beautify :initarg :beautify)))

(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))