;;; MMD by David A. Moon is licensed under a
;;; Creative Commons Attribution-ShareAlike 4.0 International License
;;; http://creativecommons.org/licenses/by-sa/4.0/
;;;
;;; Please inform me if you find this useful, or any of the ideas embedded in it.
;;; Comments and criticisms to dave underscore moon atsign alum dot mit dot edu.

(in-package cl-user)

;;; Convert MMD to HTML

(defvar *mmd-directory* (pathname-directory *load-pathname*))

(defvar *input-stream*)
(defvar *output-stream*)
(defvar *output-directory*)
(defvar *line-number*)
(defvar *title-prefix*)
(defvar *page-number*)
(defvar *current-chapter-name*)
(defvar *page-titles*)           ; ((chapter (section (subsection...))...)...)
(defvar *all-references*)        ; ((.see-arg . href) ...)
(defvar *all-anchors*)           ; hash-table of "chapter#anchor"
(defvar *pre-html*)
(defvar *post-html*)
(defvar *this-page-file*)
(defvar *previous-page-file*)
(defvar *current-mode*) ; NIL, TABLE, UL, or OL
(defvar *nesting-level*)
(defvar *directive-name*)
(defvar *code-style*)

(defvar *dot-handlers* (make-hash-table :test #'equal))
(defmacro defdot (name (line &key before after) &body body)
  (let ((symbol1 (intern (concatenate 'string "BEFORE-DOT-" (string name)) "CL-USER"))
        (symbol2 (intern (concatenate 'string "HANDLE-DOT-" (string name)) "CL-USER"))
        (symbol3 (intern (concatenate 'string "AFTER-DOT-" (string name)) "CL-USER")))
    `(progn
       (setf (gethash ,(string-downcase (string name)) *dot-handlers*)
             '(,symbol1 ,symbol2 ,symbol3))
       (defun ,symbol2 (,line) ,@body)
       (defun ,symbol1 () ,before)
       (defun ,symbol3 () ,after))))

;;; Main Program
(defun mmd (&optional (input-pathname (ccl::choose-file-dialog :file-types '("MMD"))))
  (with-open-file (*input-stream* input-pathname :element-type 'character :external-format :UTF-8)
    (setq *output-directory* (make-pathname :defaults (pathname *input-stream*)
                                            :directory (append (pathname-directory *input-stream*) '("HTML"))
                                            :name nil :type nil :version nil))
    (let ((*line-number* 0)
          (*page-number* 0)
          (*title-prefix* nil)
          (*current-chapter-name* nil)
          (*page-titles* '())
          (*all-references* '())
          (*all-anchors* (make-hash-table :test #'equal))
          (*pre-html* '())
          (*post-html* '())
          (*output-stream* nil)
          (*this-page-file* nil)
          (*previous-page-file* nil)
          (*current-mode* nil)
          (*nesting-level* nil)
          (*code-style* "display:table; border:1px solid black; background-color:whitesmoke; padding-left:5px; padding-right:5px; padding-top:5px; padding-bottom:5px"))
      (unwind-protect
        (progn
          ;; Process lines until end of input file
          (loop as line = (next-line) until (null line)
                as line-number = *line-number*
                as first = (position #\space line :test-not #'eql) do
            (with-simple-restart
                (skip "Skip line ~D" line-number)
              (cond ((= (length line) 0)
                     ;; Blank line separates paragraphs
                     (when *output-stream*
                       (change-mode nil)
                       (output-raw "<P>")))
                    ((char= (char line 0) #\.)
                     (directive-line line))
                    ((char= (char line first) #\*)
                     (list-line line 'UL))
                    ((char= (char line first) #\#)
                     (list-line line 'OL))
                    ((char= (char line 0) #\|)
                     (table-line line))
                    (t
                     (change-mode nil)
                     (output-with-flags-and-translations line)))))
          (end-page nil)

          ;; Check for broken links
          (loop for (line . href) in *all-references* do
            (unless (gethash href *all-anchors*)
              (format *error-output* "~&Broken link: .see ~A~%"
                      line)))

          ;; Generate index.html file
          (with-open-file (*output-stream* (make-pathname :defaults *output-directory* :name "index" :type "html")
                                           :direction :output :if-exists :supersede)
            (output-index)
            (pathname *output-stream*)))
        ;; Cleanup
        (when *output-stream* (close *output-stream*))))))

;;; Line Handlers

(defun directive-line (line)
  (change-mode nil)
  (let* ((space (position #\space line))
         (*directive-name* (subseq line 1 space))
         (dotname (string-downcase *directive-name*))
         (handlers (gethash dotname *dot-handlers*)))
    (unless handlers
      (error "Unrecognized directive .~A on line ~D" dotname *line-number*))
    (funcall (first handlers))
    (if space
      (funcall (second handlers) (subseq line (+ space 1)))
      (loop with end-line = (concatenate 'string ".end " dotname)
            while (and (setq line (next-line))
                       (not (equal line end-line)))
        do (funcall (second handlers) line)))
    (funcall (third handlers))))

(defun list-line (line mode)
  (change-mode mode)
  (setq line (string-left-trim '(#\space) line))
  (let ((level (position (char line 0) line :test-not #'eql)))
    (assert (> level 0))
    (loop while (> *nesting-level* level) do
      (output-raw (format nil "</~A>" mode))
      (decf *nesting-level*))
    (loop while (< *nesting-level* level)
          as type = (if (< *nesting-level* 3) (char "1ai" *nesting-level*) #\1) do
      (output-raw (if (eq mode 'UL) "<UL>" (format nil "<OL type=\"~C\">" type)))
      (incf *nesting-level*))
    (output-raw "<LI>" :newline nil)
    (output-with-flags-and-translations line :start level :newline nil)
    (output-raw "</LI>" :newline t)))

(defun enter-ul-mode ()
  (output-raw "<UL>"))

(defun leave-ul-mode ()
  (output-raw "</UL>"))

(defun enter-ol-mode ()
  (output-raw "<OL type=1>"))

(defun leave-ol-mode ()
  (output-raw "</OL>"))

(defun table-line (line)
  (change-mode 'TABLE)
  (unless (eql #\| (char line (1- (length line))))
    (error "Missing closing | in ~S on line ~D" line *line-number*))
  ;; A header column will retain an extra | at the start
  (let ((start 1) (next 1) (end (length line)) (columns '()))
    (loop while (< next end) do
      (setq next (position-if #'(lambda (x) (or (eql x #\`) (eql x #\|))) line :start next :end end))
      (cond ((not next)
             (error "Parsing error after ~D in ~S on line ~D" start line *line-number*))
            ((and (= next start) (eql (char line next) #\|))
             ;; Skip over second | in ||
             (setq next (+ next 1)))
            ((eql (char line next) #\`)
             ;; Skip over | inside of ` pair
             (setq next (+ (position #\` line :start (+ next 2)) 1)))
            (t
             ;; Found end of column
             (push (string-trim '(#\space) (subseq line start next)) columns)
             (setq next (setq start (+ next 1))))))
    (output-raw "<TR>")
    (dolist (column (reverse columns))
      (cond ((and (> (length column) 0) (eql #\| (char column 0)))
             ;; This is a heading
             (output-raw "<TH style=\"border: 1px solid black; padding: 8pt;\">" :newline nil)
             (output-with-flags-and-translations (subseq column 1))
             (output-raw "</TH>"))
            (t
             (output-raw "<TD style=\"border: 1px solid black; padding: 8pt;\">" :newline nil)
             (output-with-flags-and-translations column)
             (output-raw "</TD>"))))
    (output-raw "</TR>")))

(defun enter-table-mode ()
  (output-raw "<TABLE style=\"border-collapse: collapse; border: 1px solid black;\">"))

(defun leave-table-mode ()
  (output-raw "</TABLE>"))


;;; Directives

;; .chapter, .section, and .subsection produce a table of contents
;; in the index.html file.  Each chapter goes in its own .html file.
(defdot chapter (line)
  (when *output-stream*
    (end-page (chapter-name line)))
  (push (cons line nil) *page-titles*)
  (setq *current-chapter-name* (chapter-name line))
  (set-anchor line)
  (set-anchor "")
  (start-page line)
  (output-raw (concatenate 'string "<h2 id=\"" (anchor-name line) "\">" line "</h2>")))

(defdot section (line)
  (push (cons line nil) (cdar *page-titles*))
  (set-anchor line)
  (output-raw (concatenate 'string "<h3 id=\"" (anchor-name line) "\">" line "</h3>")))

(defdot subsection (line)
  (push (cons line nil) (cdadar *page-titles*))
  (set-anchor line)
  (output-raw (concatenate 'string "<h4 id=\"" (anchor-name line) "\">" line "</h4>")))

(defdot anchor (line)
  (set-anchor line)
  (output-raw (format nil "<A id=\"~A\"/>" (anchor-name line))))

(defun set-anchor (line)
  (setf (gethash (concatenate 'string *current-chapter-name* ".html#" (anchor-name line)) *all-anchors*) t))

;; Remove all but letters and numbers, change spaces to underscores
(defun anchor-name (title)
  (with-output-to-string (s)
    (loop for i from 0 below (length title)
          as char = (char title i) do
      (cond ((and (< (char-code char) 128)
                  (or (alpha-char-p char) (digit-char-p char)))
             (write-char (char-downcase char) s))
            ((eql char #\space)
             (write-char #\_ s))))))

;; Remove all but letters and numbers, change spaces to underscores, can't be "index"
(defun chapter-name (title)
  (let ((name (anchor-name title)))
    (if (equal name "index") "index_" name)))

;; chapter
;; #anchor
;; chapter#anchor
;; Returns (values chapter anchor) where chapter can be nil
(defun decode-see (line)
  (let* ((sharp (position #\# line))
         (first (subseq line 0 sharp))
         (second (and sharp (subseq line (+ sharp 1))))
         (chapter (cond ((not sharp) line)
                        ((> sharp 0) first)
                        (t nil)))
         (anchor (if sharp second "")))
    (values chapter anchor)))

(defun make-href (line)
  (multiple-value-bind (chapter anchor) (decode-see line)
    (concatenate 'string (if chapter (chapter-name chapter) *current-chapter-name*)
                         ".html#"
                         (anchor-name anchor))))

;; .see chapter#anchor
(defdot see (line)
  (multiple-value-bind (chapter anchor) (decode-see line)
    (let ((href (make-href line)))
      (push (cons line href) *all-references*)
      (output-raw (concatenate 'string *directive-name*
                                       " <A href=\"" href "\">"
                                       (if (equal anchor "") chapter anchor)
                                       "</A>")))))

;; .code displays a block of code
(defdot code (line :before (output-raw (concatenate 'string "<PRE style=\"" *code-style* "\">"))
                   :after  (output-raw "</PRE>"))
  (when (and (> (length line) 9)
             (equal (subseq line 0 9) ".QUOTE!! "))
    (setq line (subseq line 9)))
  (output-with-translations line))

(defdot codestyle (line)
  (setq  *code-style* line))

;; .comment comments-out its directed lines
(defdot comment (line)
  (declare (ignore line)))

;; .html inserts raw HTML directly into the formatted output
(defdot html (line)
  (output-raw line))

(defdot prehtml (line)
  (setq *pre-html* (nconc *pre-html* (list line))))

(defdot posthtml (line)
  (setq *post-html* (nconc *post-html* (list line))))

;; .title inserts a prefix and a colon space before each page title
(defdot title (line)
  (setq *title-prefix* line))


;;; Subroutines

;;; Begin or end a table or list
(defun change-mode (new-mode)
  (unless (eq new-mode *current-mode*)
    (case *current-mode*
      (TABLE (leave-table-mode))
      (UL (leave-UL-mode))
      (OL (leave-OL-mode)))
    (setq *current-mode* new-mode)
    (setq *nesting-level* 1)
    (case new-mode
      (TABLE (enter-table-mode))
      (UL (enter-UL-mode))
      (OL (enter-OL-mode)))))

(defconstant *space-tab* (coerce '(#\space #\tab) 'string))
(defconstant *spaces* (coerce (loop repeat 8 collect #\space) 'string))

;;; Read line, strip trailing spaces, convert tabs, null at EOF
(defun next-line ()
  (let ((line (read-line *input-stream* nil nil)))
    (when line
      (setq line (string-right-trim *space-tab* line))
      (loop as pos = (position #\tab line)
            while pos
            do (setq line (concatenate 'string (subseq line 0 pos)
                                               (subseq *spaces* (mod pos 8))
                                               (subseq line (1+ pos)))))
      (incf *line-number*)
      line)))

;; Start a non-index page
(defun start-page (title)
  (incf *page-number*)
  (setq *previous-page-file* *this-page-file*)
  (setq *this-page-file* (chapter-name title))
  (setq *output-stream* (open (make-pathname :defaults *output-directory* :name *this-page-file* :type "html")
                              :element-type '(unsigned-byte 8)
                              :direction :output :if-exists :supersede))
  (output-raw "<!DOCTYPE html>")
  (output-raw "<html><head>")
  (output-raw "<title>")
  (when *title-prefix*
    (output-with-translations *title-prefix*)
    (output-raw ": "))
  (output-with-translations title)
  (output-raw "</title></head><body>")
  (mapc #'output-raw *pre-html*))

;; End a non-index page
(defun end-page (next-chapter-name)
  (when *output-stream*
    (change-mode nil)
    ;; Navigation
    (let ((first (= *page-number* 1))
          (prev-page (format nil "~A.html" *previous-page-file*))
          (next-page (format nil "~A.html" next-chapter-name)))
      (output-raw "<BR><P align=center>")
      (output-raw (format nil "<A HREF=~S>" (if first "index.html" prev-page)) :newline nil)
      (output-raw "Previous page" :newline nil)
      (output-raw "</A>" :newline nil)
      (output-raw "&nbsp;&nbsp;&nbsp;<A HREF=\"index.html\">Table of Contents</A>&nbsp;&nbsp;&nbsp;" :newline nil)
      (when next-chapter-name
        (output-raw (format nil "<A HREF=~S>" next-page) :newline nil)
        (output-raw "Next page" :newline nil)
        (output-raw "</A>" :newline nil))
      (output-raw "</P>"))
    ;; Bottom of page material
    (mapc #'output-raw *post-html*)
    (output-raw "</body></html>")
    (close *output-stream*)
    (setq *output-stream* nil)))

;; Generate the table of contents
(defun output-index ()
  (format *output-stream* "<!DOCTYPE html>~%<html><head><title>~A~A</title>~%"
          (if *title-prefix* (concatenate 'string *title-prefix* ": ") "")
          "Table of Contents")
  ;; Thank you Tyler Uebele !!
  (write-line "<script type=\"text/javascript\" src=\"details-shim.min.js\"></script>" *output-stream*)
  (write-line "<link rel=\"stylesheet\" type=\"text/css\" href=\"details-shim.min.css\">" *output-stream*)
  (let ((shim-directory (append *mmd-directory* '("details-shim"))))
    (copy-file (make-pathname :name "details-shim" :type "min.js" :directory shim-directory)
               (make-pathname :name "details-shim" :type "min.js" :defaults *output-directory*)
               :if-exists :overwrite)
    (copy-file (make-pathname :name "details-shim" :type "min.css" :directory shim-directory)
               (make-pathname :name "details-shim" :type "min.css" :defaults *output-directory*)
               :if-exists :overwrite))
  (write-line "</head><body>" *output-stream*)
  (dolist (line *pre-html*)
    (write-line line *output-stream*))
  (multiple-value-bind (second minute hour date month year)
      (decode-universal-time (get-universal-time))
    (declare (ignore second minute hour))
    (format *output-stream* "Last updated ~D/~D/~D.<BR>~%" month date year))
  (format *output-stream* "<h2>Table of Contents</h2>~%")
  (loop for page-no from 1 and (title . sections) in (reverse *page-titles*)
        as page-name = (chapter-name title) do
    (if sections
      (write-line "<details><summary>" *output-stream*)
      (write-string "<div style=\"margin-left:1.6em\">"  *output-stream*))
    (format *output-stream* "~D. <A HREF=\"~A.html\">~A</A><BR>"
            page-no page-name title)
    (if sections
      (write-line "</summary>" *output-stream*)
      (write-line "</div>"  *output-stream*))
    (loop for section-no from 1 and (title . subsections) in (reverse sections) do
      (format *output-stream* "<div style=\"margin-left:2.3em\">~D.~D <A HREF=\"~A.html#~A\">~A</A><BR></div>~%"
              page-no section-no page-name (anchor-name title) title)
      (loop for subsection-no from 1 and (title . nil) in (reverse subsections) do
        (format *output-stream* "<div style=\"margin-left:4em\">~D.~D.~D <A HREF=\"~A.html#~A\">~A</A><BR></div>~%"
                page-no section-no subsection-no page-name (anchor-name title) title)))
    (when sections
      (write-line "</details>" *output-stream*)))
  (write-line "<BR>" *output-stream*)
  (dolist (line *post-html*)
    (write-line line *output-stream*))
  (format *output-stream* "</body></html>~%"))

;; Output HTML directly
(defun output-raw (line &key (newline t))
  (loop for pos from 0 below (length line)
        as char = (char line pos)
        as code = (char-code char)
    do (cond ((<= 32 code 126)
              (write-byte code *output-stream*))
             (t
              (error "Invalid character ~C code ~D on line ~D" char code *line-number*))))
  (when newline
    (write-byte 10 *output-stream*)))

;; Output with character translations
(defun output-with-translations (line &key (start 0) (end (length line)) (newline t))
  (loop for pos from start below end
        as char = (char line pos)
        as code = (char-code char)
    do (cond ((< code 32)
              (error "Invalid character code ~D on line ~D" code *line-number*))
             ((eql char #\<)
              (output-raw "&lt;" :newline nil))
             ((eql char #\>)
              (output-raw "&gt;" :newline nil))
             ((eql char #\&)
              (output-raw "&amp;" :newline nil))
             ((> code 126)
              (output-raw "&#x" :newline nil)
              (loop for shift from -12 to 0 by 4
                    as higit = (logand 15 (ash code shift))
                do (write-byte (+ higit (if (< higit 10) 48 55)) *output-stream*))
              (write-byte (char-code #\;) *output-stream*))
             (t
              (write-byte code *output-stream*))))
  (when newline
    (write-byte 10 *output-stream*))) ; newline

;; Output with style flags and character translations
(defun output-with-flags-and-translations (line &key (start 0) (end (length line)) (newline t))
  (let ((pos start))
    (loop while (< pos end)
          as next = (position-if #'(lambda (x) (or (eql x #\`) (eql x #\\))) line :start pos :end end)
      do (cond ((not next)
                (return-from output-with-flags-and-translations
                             (output-with-translations line :start pos :end end :newline newline)))
               ((> next pos)
                (output-with-translations line :start pos :end next :newline nil)))
         (setq pos next)
         (unless (and (<= (+ pos 2) end) (setq next (position (char line pos) line :start (+ pos 2))))
           (error "Mismatched ~C in ~A on line ~D" (char line pos) line *line-number*))
         (cond ((eql (char line pos) #\`)
                (output-raw "<TT>" :newline nil)
                (output-with-translations line :start (+ pos 1) :end next :newline nil)
                (output-raw "</TT>" :newline nil)
                (setq pos (+ next 1)))
               ((eql (char line (+ pos 1)) #\\)
                (unless (and (< next end) (eql (char line (+ next 1)) #\\))
                  (error "Mismatched \\\\ in ~A on line ~D" line *line-number*))
                (output-raw "<strong>" :newline nil)
                (output-with-flags-and-translations line :start (+ pos 2) :end next :newline nil)
                (output-raw "</strong>" :newline nil)
                (setq pos (+ next 2)))
               (t
                (output-raw "<em>" :newline nil)
                (output-with-flags-and-translations line :start (+ pos 1) :end next :newline nil)
                (output-raw "</em>" :newline nil)
                (setq pos (+ next 1))))))
  (when newline
    (write-byte 10 *output-stream*))) ; newline