(in-package :mgl-pax)

(in-readtable pythonic-string-syntax)

(defsection @documentation-utilities
    (:title "Utilities for Generating Documentation")
  "Two convenience functions are provided to serve the common case of
  having an ASDF system with some readmes and a directory with for the
  HTML documentation and the default CSS stylesheet."
  (update-asdf-system-readmes function)
  (@html-output section)
  (@github-workflow section)
  (@pax-world section))

(defparameter *default-output-options*
  '(:if-does-not-exist :create
    :if-exists :supersede
    :ensure-directories-exist t))

(defun/autoloaded update-asdf-system-readmes
    (object asdf-system &key (url-versions '(1)) (formats '(:markdown)))
  "Convenience function to generate up to two readme files in the
  directory holding the ASDF-SYSTEM definition. OBJECT is passed on to
  DOCUMENT.

  If :MARKDOWN is in FORMATS, then `README.md` is generated with
  anchors, links, inline code, and other markup added. Not necessarily
  the easiest on the eye in an editor but looks good on github.

  If :PLAIN is in FORMATS, then `\\\\README` is generated, which is
  optimized for reading in text format. It has less cluttery markup
  and no [autolinking][@explicit-and-autolinking section].

  Example usage:

  ```
  (update-asdf-system-readmes @pax-manual :mgl-pax
                              :formats '(:markdown :plain))
  ```

  Note that *DOCUMENT-URL-VERSIONS* is bound to URL-VERSIONS, which
  defaults to using the uglier, version 1 style of URL for the sake of
  github."
  (when (member :markdown formats)
    (with-open-file (stream (asdf:system-relative-pathname
                             asdf-system "README.md")
                            :direction :output
                            :if-does-not-exist :create
                            :if-exists :supersede
                            :external-format *utf-8-external-format*)
      (let ((*document-url-versions* url-versions))
        (document object :stream stream :format :markdown))
      (print-markdown-footer stream)))
  (when (member :plain formats)
    (with-open-file (stream (asdf:system-relative-pathname
                             asdf-system "README")
                            :direction :output
                            :if-does-not-exist :create
                            :if-exists :supersede
                            :external-format *utf-8-external-format*)
      (document object :stream stream :format :plain)
      (print-markdown-footer stream))))

(defun print-markdown-footer (stream)
  (format stream "~%* * *~%")
  (format stream "###### \\[generated by ~
                 [MGL-PAX](https://github.com/melisgl/mgl-pax)\\]~%"))


(defsection @html-output (:title "HTML Output")
  (update-asdf-system-html-docs function)
  "See the following variables, which control HTML generation."
  (*document-html-default-style* variable)
  (*document-html-max-navigation-table-of-contents-level* variable)
  (*document-html-head* variable)
  (*document-html-sidebar* variable)
  (*document-html-top-blocks-of-links* variable)
  (*document-html-bottom-blocks-of-links* variable))

(defvar *document-html-default-style* :default
  "The HTML style to use. It's either STYLE is either :DEFAULT or
  :CHARTER. The :DEFAULT CSS stylesheet relies on the default
  fonts (sans-serif, serif, monospace), while :CHARTER bundles some
  fonts for a more controlled look.

  The value of this variable affects the default style of
  UPDATE-ASDF-SYSTEM-HTML-DOCS. If you change this variable, you may
  need to do a hard refresh in the browser (often `C-<f5>`). See
  *BROWSE-HTML-STYLE* for how to control the style used for
  @BROWSING-LIVE-DOCUMENTATION.")

(defun/autoloaded update-asdf-system-html-docs
    (sections asdf-system &key pages
              (target-dir (asdf:system-relative-pathname
                           asdf-system "doc/"))
              (update-css-p t)
              (style *document-html-default-style*))
  "Generate pretty HTML documentation for a single ASDF system,
  possibly linking to github. If UPDATE-CSS-P, copy the STYLE files to
  TARGET-DIR (see *DOCUMENT-HTML-DEFAULT-STYLE*).

  Example usage:

  ```
  (update-asdf-system-html-docs @pax-manual :mgl-pax)
  ```

  The same, linking to the sources on github:

  ```
  (update-asdf-system-html-docs
    @pax-manual :mgl-pax
    :pages
    `((:objects (,mgl-pax::@pax-manual)
       :source-uri-fn ,(make-git-source-uri-fn
                        :mgl-pax
                        \"https://github.com/melisgl/mgl-pax\"))))
  ```"
  (document-html sections pages target-dir update-css-p style nil))

;;; Generate with the default HTML look.
(defun document-html (sections page-specs target-dir update-css-p style
                      link-to-pax-world-p)
  (when update-css-p
    (copy-css style target-dir))
  (document sections
            :pages (add-html-defaults-to-page-specs
                    (ensure-list sections) page-specs target-dir
                    link-to-pax-world-p)
            :format :html))

(defun add-html-defaults-to-page-specs (sections page-specs dir
                                        link-to-pax-world-p)
  (flet ((section-has-page-spec-p (section)
           (some (lambda (page-spec)
                   (member section (getf page-spec :objects)))
                 page-specs)))
    (mapcar (lambda (page-spec)
              (add-html-defaults-to-page-spec page-spec dir
                                              link-to-pax-world-p))
            (append page-specs
                    (mapcar (lambda (section)
                              `(:objects (,section)))
                            (remove-if #'section-has-page-spec-p sections))))))

(defun add-html-defaults-to-page-spec (page-spec dir link-to-pax-world-p)
  (let* ((objects (getf page-spec :objects))
         (section (if (and (= 1 (length objects))
                           (typep (first objects) 'section))
                      (first objects)
                      nil))
         (filename (and dir (sections-to-filename objects dir))))
    (flet ((header (stream)
             (let ((title (if section
                              (section-title section)
                              nil)))
               (html-header stream :title title
                                   :stylesheet "style.css" :charset "UTF-8"
                                   :link-to-pax-world-p link-to-pax-world-p)))
           (footer (stream)
             (html-footer stream)))
      `(,@page-spec
        ,@(when (eq (getf page-spec :output '%missing) '%missing)
            `(:output (,filename ,@*default-output-options*)))
        ,@(when (eq (getf page-spec :header-fn '%missing) '%missing)
            `(:header-fn ,#'header))
        ,@(when (eq (getf page-spec :footer-fn '%missing) '%missing)
            `(:footer-fn ,#'footer))))))

(defun sections-to-filename (sections dir)
  (flet ((name (section)
           (string-downcase
            (remove-special-chars (symbol-name (section-name section))))))
    (merge-pathnames (format nil "~{~A~^-~}.html"
                             (mapcar #'name sections))
                     dir)))

(defun remove-special-chars (string)
  (remove-if (lambda (char)
               (find char "!@#$%^&*/"))
             string))

(defun copy-css (style target-dir)
  (copy-dir (html-style-dir style) target-dir))

(defun copy-dir (dir to-dir)
  (dolist (file (uiop:directory* (merge-pathnames "*.*" dir)))
    (let* ((relative-file (enough-namestring (namestring file) dir))
           (to-file (merge-pathnames relative-file to-dir)))
      (uiop:delete-file-if-exists to-file)
      (ensure-directories-exist to-file)
      (if (uiop:file-pathname-p file)
          (uiop:copy-file file to-file)
          (copy-dir file to-file)))))

(defun html-style-dir (style)
  (asdf:system-relative-pathname :mgl-pax (ecase style
                                            ((:default) "web/default/")
                                            ((:charter) "web/charter/"))))

(defvar *document-html-head* nil
  "Stuff to be included in the `<head>` of the generated HTML.

  - If NIL, nothing is included.

  - If a STRING, then it is written to the HTML output as is without
    any escaping.

  - If a function designator, then it is called with a single
    argument, the HTML stream, where it must write the output.")

(defvar *document-html-sidebar* nil
  "Stuff to be included in the HTML sidebar.

  - If NIL, a default sidebar is generated, with
    *DOCUMENT-HTML-TOP-BLOCKS-OF-LINKS*, followed by the dynamic table
    of contents, and *DOCUMENT-HTML-BOTTOM-BLOCKS-OF-LINKS*.

  - If a STRING, then it is written to the HTML output as is without
    any escaping.

  - If a function designator, then it is called with a single
    argument, the HTML stream, where it must write the output.")

(defvar *document-html-top-blocks-of-links* ()
  "A list of blocks of links to be displayed on the sidebar on the left,
  above the table of contents. A block is of the form `(&KEY TITLE ID
  LINKS)`, where TITLE will be displayed at the top of the block in a
  HTML `DIV` with `ID` followed by the links. LINKS is a list of `(URI
  LABEL)` elements, where `URI` maybe a string or an object being
  DOCUMENTed or a REFERENCE thereof.")

(defvar *document-html-bottom-blocks-of-links* ()
  "Like *DOCUMENT-HTML-TOP-BLOCKS-OF-LINKS*, only it is displayed
  below the table of contents.")

(defun html-header
    (stream &key title stylesheet (charset "UTF-8")
              link-to-pax-world-p
              (head *document-html-head*)
              (sidebar *document-html-sidebar*)
              (top-blocks-of-links *document-html-top-blocks-of-links*)
              (bottom-blocks-of-links *document-html-bottom-blocks-of-links*))
  (format
   stream
   """<!DOCTYPE html>~%~
   <html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en' lang='en'>~%~
   <head>~%~
   ~@[<title>~A</title>~]~%~
   ~@[<link type='text/css' href='~A' rel='stylesheet'>~]~%~
   ~@[<meta http-equiv="Content-Type" content="text/html; ~
   charset=~A">~]~%~
   <meta name="viewport" content="width=device-width">
   <script src="jquery.min.js"></script>~%~
   <script src="toc.min.js"></script>~%~
   <script type="text/x-mathjax-config">
     MathJax.Hub.Config({
       tex2jax: {
         inlineMath: [['$','$']],
         processEscapes: true
       }
     });
   </script>
   <script async src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.7/MathJax.js?config=TeX-MML-AM_CHTML">
   </script>
   ~@[~A~]~%~
   </head>~%~
   <body>~%~
   <div id="content-container">~%"""
   (make-plain title) stylesheet charset
   (etypecase head
     ((or null string)
      head)
     ((or symbol function)
      (with-output-to-string (stream)
        (funcall head stream)))))
  (etypecase sidebar
    (null
     (generate-sidebar stream top-blocks-of-links link-to-pax-world-p
                       bottom-blocks-of-links))
    (string
     (write sidebar :stream stream))
    ((or symbol function)
     (funcall sidebar stream)))
  (format stream """<div id="content">~%"""))

(defun generate-sidebar (stream top-blocks-of-links link-to-pax-world-p
                         bottom-blocks-of-links)
  (format stream """<div id="toc">~%~
       ~A~
       ~:[~;<div id="toc-header"><ul><li><a href="index.html">~
            PAX World</a></li></ul></div>~%~]~
       <div id="page-toc">~%~
       </div>~%~
       ~A~
       <div id="toc-footer">~
         <ul><li><a href="https://github.com/melisgl/mgl-pax">[generated ~
             by MGL-PAX]</a></li></ul>~
       </div>~%~
     </div>~%"""
   (blocks-of-links-to-html-string top-blocks-of-links)
   link-to-pax-world-p
   (blocks-of-links-to-html-string bottom-blocks-of-links)))

(defun blocks-of-links-to-html-string (blocks-of-links)
  (if (listp blocks-of-links)
      (format nil "~{~A~}" (mapcar #'block-of-links-to-html-string
                                   blocks-of-links))
      (funcall blocks-of-links)))

(defun block-of-links-to-html-string (block-of-links)
  (destructuring-bind (&key title id uri links) block-of-links
    (with-output-to-string (stream)
      (format stream "<div class=\"menu-block\"")
      (when id
        (format stream " id=\"~A\"" id))
      (format stream ">")
      (when title
        (format stream "<span class=\"menu-block-title\">")
        (if uri
            (format stream "<a href=~A>~A</a>"
                    (if (stringp uri)
                        uri
                        (object-to-uri uri))
                    title)
            (format stream "~A" title))
        (format stream "</span>"))
      (format stream "<ul>")
      (dolist (link links)
        (format stream "<li>~A</li>" (link-in-block-to-html link)))
      (princ "</ul></div>" stream))))

(defun link-in-block-to-html (link-in-block)
  (destructuring-bind (url text) link-in-block
    (if (stringp url)
        (format nil "<a href=\"~A\">~A</a>" url text)
        (let ((uri (object-to-uri url)))
          (if uri
              (format nil "<a href=\"~A\">~A</a>" uri text)
              ;; KLUDGE: It's not strictly a reflink, but close enough.
              (signal-unresolvable-reflink
               `(:reference-link :label (,text)
                                 :definition (,(princ-to-string url)))
               text url))))))

(defvar *google-analytics-id* nil)

(defun html-footer (stream &key (google-analytics-id *google-analytics-id*))
  (format
   stream
   "  </div>~%~
   </div>~%~
   <script>$('#page-toc').toc(~A);</script>~%~
   ~:[~;<script>
   (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){~
   (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement~
   (o),m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.~
   insertBefore(a,m)})(window,document,'script','//www.google-analytics.com/~
   analytics.js','ga');ga('create', '~A', 'auto');ga('send', 'pageview');~
   </script>~%~]</body>~%</html>~%"
   (toc-options)
   google-analytics-id google-analytics-id))

(defvar *document-html-max-navigation-table-of-contents-level* nil
  "NIL or a non-negative integer. If non-NIL, it overrides
  *DOCUMENT-MAX-NUMBERING-LEVEL* in the dynamic HTML table of contents
  on the left of the page.")

(defun toc-options ()
  (let ((max-level (or *document-html-max-navigation-table-of-contents-level*
                       *document-max-table-of-contents-level*)))
    (format nil "{'selectors': '~{~A~^,~}'}"
            (loop for i upfrom 1 upto (1+ max-level)
                  collect (format nil "h~S" i)))))


;;;; The autoloaded part of @PAX-WORLD

(defun/autoloaded update-pax-world
    (&key (docs *registered-pax-world-docs*) dir update-css-p
          (style *document-html-default-style*))
  "Generate HTML documentation for all DOCS. Files are created in
  DIR (`(asdf:system-relative-pathname :mgl-pax \"world/\")` by
  default if DIR is NIL). DOCS is a list of entries of the form (NAME
  SECTIONS PAGE-SPECS). The default for DOCS is all the sections and
  pages registered with REGISTER-DOC-IN-PAX-WORLD.

  In the absence of :HEADER-FN :FOOTER-FN, :OUTPUT, every spec in
  PAGE-SPECS is augmented with HTML headers, footers and output
  location specifications (based on the name of the section).

  If necessary a default page spec is created for every section."
  (let ((dir (or dir (asdf:system-relative-pathname :mgl-pax "world/"))))
    (multiple-value-bind (sections pages) (sections-and-pages docs)
      (create-pax-world sections pages dir update-css-p style))))

(defun sections-and-pages (registered-docs)
  (values (apply #'append (mapcar #'denoted-list
                                  (mapcar #'second registered-docs)))
          (apply #'append (mapcar #'denoted-list
                                  (mapcar #'third registered-docs)))))

;;; See LIST-DESIGNATOR.
(defun denoted-list (designator)
  (if (listp designator)
      designator
      (funcall designator)))

(defvar @pax-world-dummy)

;;; This section is not in the documentation of PAX-WORLD itself. It
;;; is dynamically extended with the list of sections for which
;;; UPDATE-PAX-WORLD was called. FIXME: this makes CREATE-PAX-WORLD
;;; not thread-safe.
(defun define-pax-world-dummy ()
  (defsection @pax-world-dummy (:title "PAX World")
    "This is a list of documents generated with
    [MGL-PAX][@pax-manual]. The documents are cross-linked: links to
    other documents are added automatically when a reference is found.
    Note that clicking on the locative type (e.g. `[function]`) will
    take you to the sources on github if possible."))

(defun create-pax-world (sections page-specs dir update-css-p style)
  (define-pax-world-dummy)
  (unwind-protect
       (progn
         (set-pax-world-list sections)
         (document-html (cons @pax-world-dummy sections)
                        (cons `(:objects
                                ,(list @pax-world-dummy)
                                :output (,(merge-pathnames "index.html" dir)
                                         ,@*default-output-options*))
                              page-specs)
                        dir update-css-p style t))
    (setq @pax-world-dummy nil)))

(defun set-pax-world-list (objects)
  (setf (slot-value @pax-world-dummy '%entries)
        (list
         ;; This is the docstring of @PAX-WORLD-DUMMY above.
         (first (section-entries @pax-world-dummy))
         (let ((objects (sort (copy-seq objects) #'string<
                              :key #'plain-section-title-or-name)))
           (with-output-to-string (stream)
             (dolist (object objects)
               (format stream "- ~S~%~%" (section-name object))))))))

(defun sections-registered-in-pax-world ()
  (sort (loop for doc in *registered-pax-world-docs*
              append (denoted-list (second doc)))
        #'string< :key #'plain-section-title-or-name))

(defun make-plain (md-string)
  (document md-string :stream nil :format :plain))

(defun plain-section-title-or-name (section)
  (make-plain (section-title-or-name section)))


;;;; Generate the READMEs and HTML docs.

(defun pax-and-dref-sections ()
  (list @pax-manual dref::@dref-manual))

(defun pax-and-dref-pages (format)
  (let ((source-uri-fn (make-git-source-uri-fn
                        :mgl-pax
                        "https://github.com/melisgl/mgl-pax"))
        (pax-file (ecase format
                    ((:plain) "README")
                    ((:markdown) "README.md")
                    ((:html) "doc/pax-manual.html")))
        (dref-file (ecase format
                     ((:plain) "dref/README")
                     ((:markdown) "dref/README.md")
                     ((:html) "doc/dref-manual.html"))))
    `((:objects (, @pax-manual)
       :output (,(asdf:system-relative-pathname "mgl-pax" pax-file)
                ,@*default-output-options*)
       ,@(unless (eq format :html)
           '(:footer-fn print-markdown-footer))
       :uri-fragment ,pax-file
       :source-uri-fn ,source-uri-fn)
      (:objects (, dref::@dref-manual)
       :output (,(asdf:system-relative-pathname "mgl-pax" dref-file)
                ,@*default-output-options*)
       ,@(unless (eq format :html)
           '(:footer-fn print-markdown-footer))
       :uri-fragment ,dref-file
       :source-uri-fn ,source-uri-fn))))

#+nil
(progn
  (asdf:load-system :mgl-pax/full)
  (time
   (let ((*document-url-versions* '(1)))
     (document (pax-and-dref-sections) :pages (pax-and-dref-pages :plain)
                                       :format :plain)
     (document (pax-and-dref-sections) :pages (pax-and-dref-pages :markdown)
                                       :format :markdown)))
  (let ((*document-downcase-uppercase-code* t))
    (update-asdf-system-html-docs (pax-and-dref-sections)
                                  :mgl-pax :pages (pax-and-dref-pages
                                                   :html)
                                  :update-css-p t :style :charter)))


;;; Load systems that use PAX and generate PAX World in
;;; <mgl-pax-asdf-system-dir>/world/. To update
;;; https://github.com/melisgl/mgl-pax-world, check out its gh-pages
;;; branch in that directory, update pax world, commit and push the
;;; changes to github.
(defun update-pax-world* ()
  ;; KLUDGE: Bind *READTABLE* so that when evaluating in Slime (e.g.
  ;; with C-x C-e), the file's readtable is not used (which leads to a
  ;; reader macro conflict with CL-SYNTAX).
  (let ((*readtable* (named-readtables:find-readtable :standard)))
    (asdf:load-system :mgl-pax/full)
    (asdf:load-system :mgl-mat)
    (asdf:load-system :named-readtables)
    (asdf:load-system :micmac)
    (asdf:load-system :mgl-gpr)
    (asdf:load-system :mgl)
    (asdf:load-system :journal)
    (asdf:load-system :trivial-utf-8)
    (asdf:load-system :try)
    (asdf:load-system :lmdb))
  (time
   (let ((*document-downcase-uppercase-code* t))
     (update-pax-world :update-css-p t :style :charter))))

#+nil
(update-pax-world*)
