src/main.lisp

(in-package sugar-qsp)

(defun entry-point (&rest args)
  (init-vars)
  (catch :terminate
    (destructuring-bind (&key source target js css body compile beautify)
        (parse-opts args)
      ;; Just compile the source
      (when compile
        (alexandria:write-string-into-file
         (make-javascript (parse-file source))
         target :if-exists :supersede)
        (return-from entry-point))
      ;; Read in body
      (when body
        (setf *html-template-body*
              (alexandria:read-file-into-string body)))
      ;; Compile the game's JS
      (push (make-javascript (parse-file source)) *js-files*)
      ;; Include js files
      (dolist (js-file js)
        (push (format nil "// Included file ~A~%~A" js-file
                      (alexandria:read-file-into-string js-file))
              *js-files*))
      ;; Include css files
      (dolist (css-file css)
        (push (format nil "// Included file ~A~%~A" css-file
                      (alexandria:read-file-into-string css-file))
              *css-files*))
      ;; Compile into one file
      (alexandria:write-string-into-file (make-html beautify) target
                                         :if-exists :supersede))))

(defun init-vars ()
  (setf *css-files* (list "
.col1 { flush: left; clear: left; width: 80%; }
.col2 { flush: right; clear: right; width: 20%; }
.row1 { height: 70%; }
.row2 { height: 30%; }
.qsp-frame {border: 1px black; }
#qsp-acts a {display: block; }
"))
  (setf *js-files* (list (compile-ps (ps-file "intrinsics.ps"))
                         (compile-ps (ps-file "api.ps"))
                         (compile-ps (ps-file "main.ps")))))

(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 make-html (beautify-js)
  (html-sources (css-sources)
                (if beautify-js
                    (js-sources)
                    (cl-uglify-js:ast-gen-code
                     (cl-uglify-js:ast-mangle
                      (cl-uglify-js:ast-squeeze
                       (parse-js:parse-js (js-sources))))
                     :beautify nil))))

(defun report-error (fmt &rest args)
  (apply #'format t fmt args)
  (break)
  (throw :terminate nil))

;;; JS

(defparameter *js-files* nil)

(defun ps-file (filename)
  (uiop/pathname:merge-pathnames*
   (format nil "src/~A" filename)
   (asdf:system-source-directory :sugar-qsp)))

(defun js-sources ()
  (format nil "~{~A~^~%~%~}" (reverse *js-files*)))

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

;;; CSS

(defparameter *css-files* nil)

(defun css-sources ()
  (format nil "~{~A~^~%~%~}" *css-files*))

;;; HTML

(defparameter *html-template-body*
  (flute:h
    (div#qsp
     (div#qsp-main.qsp-frame.col1.row1 " ")
     (hr)
     "Действия:"
     (div#qsp-acts.qsp-frame.row2 " ")
     (hr)
     "Дополнительное окно:"
     (div#qsp-stat.qsp-frame.row1 " ")
     (hr)
     "Инвентарь:"
     (div#qsp-objs.qsp-frame.row2 " "))))

(defun html-sources (&optional (css " ") (javascript " "))
  (with-output-to-string (out)
    (write
     (let ((flute:*escape-html* nil))
       (flute:h
         (html
          (head
           (title "SugarQSP"))
          (body
           *html-template-body*
           (style css)
           (script javascript)))))
     :stream out
     :pretty nil)))

(defun write-html-default-body (filename)
  (with-open-file (out filename :direction :output)
    (write *html-template-body*
           :stream out
           :pretty t)))