;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               genhtml.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    HTML generator for the documentation.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2015-08-03 <PJB> Extracted from lispdoc.
;;;;BUGS
;;;;LEGAL
;;;;    LLGPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2015 - 2016
;;;;
;;;;    This library is licenced under the Lisp Lesser General Public
;;;;    License.
;;;;
;;;;    This library is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later
;;;;    version.
;;;;
;;;;    This library is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU Lesser General Public License for more
;;;;    details.
;;;;
;;;;    You should have received a copy of the GNU Lesser General
;;;;    Public License along with this library; if not, write to the
;;;;    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
(in-package "COM.INFORMATIMAGO.LISPDOC.GENERATE.HTML")


;;;----------------------------------------------------------------------
;;;
;;; processing pjb docstrings.
;;;


(defun replace-urls (text)
  "
Search all the urls in the text, and replace them with an A tag.
"
  (let ((start 0))
    (loop
      (multiple-value-bind (wbegin wend begins ends)
          (scan '(:sequence #\< (:register uri) #\>) text :start start)
        (declare (ignore wbegin wend))
        (if begins
            (let ((begin (aref begins 0))
                  (end   (aref ends   0)))
              (pcdata "~A" (subseq text start begin))
              (let ((url (subseq text begin end)))
                (a (:href url) (pcdata "~A" url)))
              (setf start end))
            (progn
              (pcdata "~A" (subseq text start (length text)))
              (return)))))))

(defun pjb-docstring (docstring)
  (if (eq :undocumented docstring)
      (p (:class "undocumented")
         (i - (pcdata "undocumented")))
      (pre (:class "docstring")
           (replace-urls docstring))))


;;;----------------------------------------------------------------------
;;;
;;; Documentation HTML generation
;;;

(defun report-file (path)
  (format *trace-output* "~&;; Writing file ~A~%" path)
  path)

(defun style-sheet ()
  (link (:rel "stylesheet" :type "text/css" :href "style.css")))

(defun create-style-sheet ()
  (with-open-file (css (report-file "style.css")
                       :direction :output
                       :if-does-not-exist :create
                       :if-exists :supersede
                       :external-format :utf-8)
    (format css "
body {
  margin: 10px;
  padding: 10px;
}

pre.docstring {
  margin: 20px;
}

div.symbol {
  padding:2px;
  background-color:#ddeeee;
}

div.kind {
  padding:2px;
  background-color:#ddeeee;
}

.undocumented {
  foreground-color:#ff0000;
}

.menu a {
  background-color:#80a0a0;
  border:1px solid #308080;
  padding:2px;
}

.menu input {
  color:#000000;
  background-color:#80a0a0;
  border:1px solid #308080;
  padding:2px;
}

.menu a:link    {color:#000000;}  /* unvisited link */
.menu a:visited {color:#004444;}  /* visited link */
.menu a:hover   {color:#FFFFFF;}  /* mouse over link */
.menu a:active  {color:#00FFFF;}  /* selected link */

.header p { font-size:80%; }
.footer p { font-size:80%; }
")))




(defun doc-title (name arglist kind)
  (a (:name (if (atom name)
                (format nil "~A" (symbol-name name))
                (format nil "(SETF ~A)" (symbol-name (second name))))))
  (table (:border "0" :width "100%")
         (tr -
             (td (:valign "top" :align "left")
                 (div (:class "symbol")
                     (cond
                       ((not (member kind '(:function :generic-function :macro)))
                        (b - (pcdata "~A" (right-case name))))
                       ((and (consp name) (eq (car name) 'setf))
                        (pcdata "(setf (")
                        (b - (pcdata "~A" (right-case (second name))))
                        (pcdata "~{ ~A~}) ~A)" (right-case (rest arglist))
                                (right-case (first arglist))))
                       (t
                        (pcdata "(")
                        (b - (pcdata "~A"  (right-case name)))
                        (pcdata "~{ ~A~}" (right-case arglist))
                        (pcdata ")")))))
             (td (:valign "top" :align "right" :width "200px")
                 (div (:class "kind")
                     (i - (pcdata "~(~A~)" kind)))))))


(defun generate-head (target &optional (title nil titlep))
  (head ()
    (title () (pcdata "~A" (if titlep title (documentation-title target))))
    (link (:rel "shortcut icon" :href "/favicon.ico"))
    (link (:rel "icon"          :href "/favicon.ico" :type "image/vnd.microsoft.icon"))
    (link (:rel "icon"          :href "/favicon.png" :type "image/png"))
    (meta (:http-equiv "Content-Type"   :content "text/html; charset=utf-8"))
    (when (author   target) (meta (:name "Author"    :content (author   target))))
    (when (email    target) (meta (:name "Reply-To"  :content (email    target))))
    (when (keywords target) (meta (:name "Keywords"  :content (keywords target))))
    (style-sheet)))


;;;---------------------------------------------------------------------
;;;
;;; HTML Documentation render
;;;


(defclass html-documentation (documentation-generator)
  ())

(defmethod initialize-instance :after ((target html-documentation) &key &allow-other-keys)
  ;; TODO: this ../index link is specific to informatimago; it should be moved to .lispdoc.run
  (setf (navigation target) `(("../index"                   ,(documentation-title target))
                              ("index"                      "Documentation Index")
                              ("hierarchical-package-index" "Hierarchical Package Index")
                              ("flat-package-index"         "Flat Package Index")
                              ("symbol-index"               "Symbol Indices"))))


(defgeneric header (target page-name))
(defgeneric footer (target page-name))


(defun make-url (page)
  (format nil "~(~A.html~)" page))

(defmethod generate-introduction ((target html-documentation))
  (create-style-sheet)
  (let ((page-name "index"))
    (with-open-file (html (report-file (make-url page-name))
                      :direction :output
                      :if-does-not-exist :create
                      :if-exists :supersede
                      :external-format :utf-8)
      (with-html-output (html :encoding :utf-8)
        (doctype :transitional
          (html ()
            (generate-head target)
            (body ()
              (header target page-name)
              (h1 () (pcdata "~A" (documentation-title target)))
              (ul -
                (loop
                  :for (fn text) :in (navigation target)
                  :unless (equalp fn page-name)
                    :do (li -  (a (:href (make-url fn)) (pcdata "~A" text)))))
              (footer target page-name))))))))


(defvar *navigation* nil
  "The current navigation menu.")

(defmethod generate-navigation-menu ((target html-documentation) &optional (entries nil entriesp))
  "
ENTRIES: A list of (list url text). Usually, some variant of (navigation target).
"
  (div (:class "menu")
    (p - (loop
           :for (filename text) :in (if entriesp
                                        entries
                                        (navigation target))
           :do (pcdata "   ")
               ;; (form (:action (make-url filename) :method "GET")
               ;;       (input (:type "submit" :value text)))
               (a (:href (make-url filename)) (pcdata "~A" text))))))


(defmethod header ((target html-documentation) page-name)
  (div (:class "header")
    (generate-navigation-menu target (remove page-name (navigation target)
                                    :test (function string=)
                                    :key (function first))))
  (hr) (br))


(defmethod footer ((target html-documentation) page-name)
  (br) (hr)
  (div (:class "footer")
    (generate-navigation-menu target (remove page-name (navigation target)
                                    :test (function string=)
                                    :key (function first)))
    (p - (pcdata (copyright target)))))


;;;---------------------------------------------------------------------
;;;
;;; HTML rendering
;;;


(defmethod render ((doc doc) (target html-documentation))
  (ecase (doc-kind doc)
    (:type
     (doc-title (doc-symbol doc) nil (doc-kind doc))
     (pjb-docstring (doc-string doc)))
    (:skip
     (format t "~&;; warning: lispdoc skipping ~s~%" (doc-symbol doc)))
    (:undocumented
     (p -
        (b - (pcdata "~A" (doc-symbol doc)))
        "    "
        (i (:class "undocumented") "undocumented")))))


(defmethod render ((doc packdoc) (target html-documentation))
  (let ((page-name (doc-name doc)))
   (with-open-file (html (report-file (make-url page-name))
                         :direction :output
                         :if-does-not-exist :create
                         :if-exists :supersede
                         :external-format :utf-8)
     (let ((title  (format nil "Package ~A" (doc-name doc)))
           (*navigation* (package-navigation-menu target page-name (or *navigation* (navigation target)))))
       (with-html-output (html :encoding :utf-8)
         (doctype :transitional
                  (html ()
                        (generate-head target)
                        (body ()
                              (header target page-name)
                              (h1 () (pcdata "~A" title))
                              (when (packdoc-nicknames doc)
                                (blockquote -
                                            (pcdata "Nicknames: ")
                                            (tt - (pcdata "~{ ~A~}" (packdoc-nicknames doc)))))
                              (pjb-docstring (doc-string doc))
                              (mapc (lambda (doc) (render doc target)) (packdoc-external-symbol-docs doc))
                              (footer target page-name))))))
     (pathname html))))


(defmethod render ((doc vardoc) (target html-documentation))
  (doc-title (doc-symbol doc) nil (doc-kind doc))
  (pjb-docstring (doc-string doc))
  (if (eq (vardoc-initial-value doc) :unbound)
      (blockquote - (pcdata "Initially unbound"))
      (blockquote - (pcdata "Initial value: ") (tt - (pcdata "~A" (vardoc-initial-value doc))))))


(defmethod render ((doc fundoc) (target html-documentation))
  (doc-title (doc-symbol doc) (fundoc-lambda-list doc) (doc-kind doc))
  (pjb-docstring (doc-string doc)))


(defmethod render ((doc classdoc) (target html-documentation))
  (doc-title (doc-symbol doc) nil (doc-kind doc))
  (pjb-docstring (doc-string doc))
  (when (classdoc-precedence-list doc)
    (blockquote -
                (pcdata "Class precedence list: ")
                (tt - (pcdata "~{ ~A~}" (classdoc-precedence-list doc)))))
  (when (classdoc-initargs doc)
    (blockquote -
                (pcdata "Class init args: ")
                (tt - (pcdata "~{ ~A~}" (classdoc-initargs doc))))))


;;;---------------------------------------------------------------------


(defmethod generate-hierarchical-package-index ((target html-documentation) tree &optional (filename "hierindex"))
  (loop
    ;; find the first node from the root that has more than one child or designate an actual package.
    :while (and (= 1 (length (tree-children tree)))
                (null (tree-package tree))
                (null (tree-package (first (tree-children tree)))))
    :do (setf tree (first (tree-children tree))))
  (flet ((filename (path)
           (format nil "~{~A~^.~}" (reverse path))))
    (let ((title (filename (tree-path tree))))
      (with-open-file (html (report-file (make-url filename))
                        :direction :output
                        :if-does-not-exist :create
                        :if-exists :supersede
                        :external-format :utf-8)
        (with-html-output (html :encoding :utf-8)
          (doctype :transitional
            (html ()
              (generate-head target title)
              (body ()
                (header target filename)
                (h1 () (pcdata "~A" title))
                (ul -
                  (dolist (child (tree-children tree))
                    (let ((childfile (filename (tree-path child))))
                      (li - (a (:href (make-url childfile))
                              (if (tree-package child)
                                  (pcdata "Package ~A" (tree-package child))
                                  (progn
                                    (pcdata "System ~A" childfile)
                                    (generate-hierarchical-package-index target child childfile))))))))
                (footer target filename)))))))))


(defmethod generate-flat-package-index ((target html-documentation) pages &optional (filename "flatindex"))
  (let ((title "Flat Package Index"))
    (with-open-file (html (report-file (make-url filename))
                      :direction :output
                      :if-does-not-exist :create
                      :if-exists :supersede
                      :external-format :utf-8)
      (with-html-output (html :encoding :utf-8)
        (doctype :transitional
          (html ()
            (generate-head target title)
            (body ()
              (header target filename)
              (h1 () (pcdata "~A" title))
              (ul -
                (dolist (page pages)
                  (li - (a (:href (make-url page))
                          (pcdata "~A" page)))))
              (footer target filename))))))))



(defmethod generate-flat-symbol-index ((target html-documentation) syms &optional (filename "flatsymindex"))
  "
RETURN: A list of (first-letter filename)
"
  (let ((groups (build-flat-symbol-index-groups syms))
        (indices '()))
    ;; Generate each group index:
    (dolist (group groups (nreverse indices))
      (let* ((group   (sort group
                            (function string-lessp)
                            :key (lambda (x) (symbol-name (doc-name x)))))
             (first-letter  (first-letter (first group)))
             (filename (format nil "~A-~A" filename first-letter))
             (title    (format nil "Alphabetical Symbol Index -- ~A" first-letter))
             (width    (reduce (function max) group
                               :key (lambda (x) (length (princ-to-string (doc-symbol x)))))))
        (push (list first-letter filename) indices)
        (with-open-file (html (report-file (make-url filename))
                          :direction :output
                          :if-does-not-exist :create
                          :if-exists :supersede
                          :external-format :utf-8)
          (with-html-output (html :encoding :utf-8)
            (doctype :transitional
              (html ()
                (generate-head target title)
                (body ()
                  (header target filename)
                  (h1 () (pcdata "~A" title))
                  (pre -
                    (dolist (sym group)
                      (let ((packname (package-name
                                       (symbol-package (doc-name sym)))))
                        (a (:href
                            (with-standard-io-syntax
                              (format nil "~A#~A"
                                      (make-url packname)
                                      (doc-symbol sym))))
                          (pcdata "~A" (doc-symbol sym)))
                        (pcdata "~V<~>" (- width -4 (length (princ-to-string (doc-symbol sym)))))
                        (a (:href (make-url packname))
                          (pcdata "~(~A~)" packname))
                        (pcdata "~%"))))
                  (footer target filename))))))))))


(defmethod generate-permuted-symbol-index ((target html-documentation) syms &optional (filename "permsymindex"))
  "
RETURN: A list of (first-letter filename)
"
  (let ((groups  (build-permuted-symbol-index-groups syms))
        (indices '()))
    ;; Generate each group index:
    (dolist (group groups (nreverse indices))
      (let ((first-letter (pop group)))
        (labels ((compute-offset (name index)
                   (if (equalp first-letter (aref name index))
                       index
                       (loop
                         :for previous :from index
                         :for i :from (1+ index) :below (length name)
                         :while (not (and (not (alpha-char-p (aref name previous)))
                                          (equalp first-letter (aref name i))))
                         :finally (return (if (< i (length name)) i nil)))))
                 (offset (doc)
                   (if (consp (doc-symbol doc))
                       (compute-offset (princ-to-string (doc-symbol doc)) (length "(setf "))
                       (compute-offset (symbol-name (doc-name doc)) 0))))
          (let* ((group    (sort  group
                                  (function string-lessp)
                                  :key (lambda (doc)
                                         (let ((name   (princ-to-string (doc-symbol doc)))
                                               (offset (offset doc)))
                                           (concatenate 'string
                                                        (subseq name offset) (subseq name 0 offset))))))
                 (filename (format nil "~A-~A" filename first-letter))
                 (title    (format nil "Permuted Symbol Index -- ~A" first-letter))
                 (indent   (reduce (lambda (a b)
                                     (cond
                                       ((null a) b)
                                       ((null b) a)
                                       (t (max a b))))
                                   group :key (function offset)))
                 (width    (reduce (function max) group
                                   :key (lambda (x) (length (princ-to-string (doc-symbol x)))))))
            (push (list first-letter filename) indices)
            (with-open-file (html (report-file (make-url filename))
                              :direction :output
                              :if-does-not-exist :create
                              :if-exists :supersede
                              :external-format :utf-8)
              (with-html-output (html :encoding :utf-8)
                (doctype :transitional
                  (html ()
                    (generate-head target title)
                    (body ()
                      (header target filename)
                      (h1 () (pcdata "~A" title))
                      (pre -
                        (dolist (sym group)
                          (let ((packname (package-name (symbol-package (doc-name sym))))
                                (offset (offset sym)))
                            (when offset
                              (pcdata (make-string (- indent (offset sym)) :initial-element #\space))
                              (a (:href (with-standard-io-syntax
                                          (format nil "~A#~A"
                                                  (make-url packname)
                                                  (doc-symbol sym))))
                                (pcdata "~A" (doc-symbol sym)))
                              (pcdata "~V<~>" (- (+ width 4)
                                                 (- (length (princ-to-string (doc-symbol sym)))
                                                    offset)))
                              (a (:href (make-url packname))
                                (pcdata "~(~A~)" packname))
                              (pcdata "~%")))))
                      (footer target filename))))))))))))


(defmethod generate-symbol-index ((target html-documentation) flat-indices permuted-indices symbol-count &optional (filename "symindex"))
  (flet ((gen-index (indices)
           (div (:class "menu")
             (loop
               :for sep = "" :then "   "
               :for (first-letter initial-filename) :in indices
               :do (progn (pcdata sep)
                          (a (:href (make-url initial-filename))
                            (pcdata "~A" (if (eq :other first-letter)
                                             "Non-Alphabebtic"
                                             first-letter))))))))
    (let ((title "Symbol Indices"))
      (with-open-file (html (report-file (make-url filename))
                        :direction :output
                        :if-does-not-exist :create
                        :if-exists :supersede
                        :external-format :utf-8)
        (with-html-output (html :encoding :utf-8)
          (doctype :transitional
            (html ()
              (generate-head target title)
              (body ()
                (header target filename)
                (h1 - (pcdata "Alphabetical Symbol Index"))
                (p - (pcdata "There are ~A symbols exported from the Informatimago Common Lisp packages."
                             symbol-count))
                (gen-index flat-indices)
                (p - (a (:href "")
                       (pcdata "Click here to see all the symbols on one page, alphabetically.")))
                (h1 - (pcdata "Permuted Symbol Index"))
                (p -
                  (pcdata "A permuted index includes each ") (i - (pcdata "n"))
                  (pcdata "-word entry up to ") (i - (pcdata "n"))
                  (pcdata " times, at points corresponding to the use of each word in the entry")
                  (pcdata " as the sort key.  For example, a symbol ") (tt - (pcdata "FOO-BAR"))
                  (pcdata " would occur twice, once under ") (tt - (pcdata "FOO"))
                  (pcdata " and ") (tt - (pcdata "BAR")) (pcdata ". This allows you to use any")
                  (pcdata " word in th symbol's name to search for that symbol."))
                (gen-index permuted-indices)
                (footer target filename)))))))))



#-(and)
(setf *index-tree*
      (make-index-tree (mapcar (function doc-name)
                          (lispdoc (sort (mapcar (lambda (package)
                                                   (if (packagep package)
                                                       package
                                                       (find-package package)))
                                                 (remove-if-not (lambda (p)
                                                                  (and (search "COM.INFORMATIMAGO" (package-name p))
                                                                       (not (search "COM.INFORMATIMAGO.PJB" (package-name p)))))
                                                                (list-all-packages)))
                                         (function string<) :key (function package-name))))))




;;;; THE END ;;;;
ViewGit