writer-html.lisp

   1 ;;; -*- lisp -*-
   2
   3 ;;;; This software was originally part of the SBCL software system.
   4 ;;;; SBCL is in the public domain and is provided with absolutely no warranty.
   5 ;;;; See the COPYING file for more information.
   6 ;;;;
   7 ;;;; Written by Nikodemus Siivola
   8
   9 (in-package #:texinfo-docstrings)
  10
  11 (define-document-format :html "html")
  12
  13 ;;;; HTML OUTPUT
  14
  15 (defvar *html-indent* 0)
  16
  17 (defmacro with-html ((stream tag attributes) &body forms)
  18   (sb-int:once-only ((stream stream) (tag tag))
  19     `(progn
  20       (format ,stream "~vT<~(~A~)~{ ~(~A~)=~S~}>~%" *html-indent* ,tag ,attributes)
  21       (let ((*html-indent* (+ 2 *html-indent*)))
  22         ,@forms)
  23       (format ,stream "~vT</~(~A~)>~%" *html-indent* ,tag))))
  24
  25 (defmethod format-document-start (stream package (format (eql :html)))
  26   (write-line "<html>" stream)
  27   (with-html (stream :head nil)
  28     (format-html stream :link '(:rel "stylesheet" :type "text/css" :href "style.css") nil)
  29     (format-html stream :title nil (package-name package)))
  30   (write-line "<body>" stream)
  31   (format-html stream :h1 '(:class "package-name") (package-name package)))
  32
  33 (defmethod format-document-end (stream package (format (eql :html)))
  34   (write-line "</body></html>" stream))
  35
  36 (defun html-escape (string)
  37   (with-output-to-string (s)
  38     (loop for char across string
  39           do (case char
  40                (#\< (write-string "&lt;" s))
  41                (#\> (write-string "&gt;" s))
  42                (#\& (write-string "&amp;" s))
  43                (t   (write-char char s))))))
  44
  45 (defun format-html (stream tag attributes string)
  46   (format stream "~vT<~(~A~)~{ ~(~A~)=~S~}~:[>~;/>~]~@[~A~]~@[</~(~A~)>~]~%"
  47           *html-indent* tag attributes (not string) string (when string tag)))
  48
  49 (defun html-text (string)
  50   (with-output-to-string (result)
  51     (let ((last 0))
  52       (dolist (symbol/index (parse-docstrings.sbcl::locate-symbols string))
  53         (write-string (html-escape (subseq string last (first symbol/index))) result)
  54         (let ((symbol-name (apply #'subseq string symbol/index)))
  55           (format result "<var>~A</var>" (html-escape symbol-name)))
  56         (setf last (second symbol/index)))
  57       (write-string (html-escape (subseq string last)) result))))
  58
  59 (defmethod format-doc (stream (doc parse-docstrings:documentation*) format)
  60   (let ((name (html-escape (princ-to-string (parse-docstrings:get-name doc)))))
  61     (with-html (stream :div '(:class "item"))
  62       (with-html (stream :div '(:class "type"))
  63         (format-html stream :a (list :name name)
  64                      (html-escape (format nil "[~A]" (string-downcase (princ-to-string (parse-docstrings:get-kind doc)))))))
  65       (with-html (stream :div '(:class "signature"))
  66         (format-html stream :code '(:class "name") name)
  67         (let ((ll (parse-docstrings:lambda-list doc)))
  68           (when ll
  69             (with-html (stream :span '(:class "args"))
  70               (dolist (elt ll)
  71                 (labels ((markup-ll (elt)
  72                            (cond ((member elt lambda-list-keywords)
  73                                   (format-html stream :code '(:class "llkw") (html-escape (princ-to-string elt))))
  74                                  ((listp elt)
  75                                   (write-string "(" stream)
  76                                   (mapcar #'markup-ll elt)
  77                                   (write-string ")" stream))
  78                                  (t
  79                                   (format-html stream :var () (html-escape (string-downcase (princ-to-string elt))))))))
  80                   (markup-ll elt)))))))
  81       (with-html (stream :div '(:class "item-body"))
  82         (let ((content (parse-docstrings:get-content doc)))
  83           (format-doc stream content format)))))
  84   (terpri stream))
  85
  86 (defmethod format-doc (stream
  87                        (lisp parse-docstrings:lisp-block)
  88                        (format (eql :html)))
  89   (format-html stream
  90                :pre
  91                '(:class "lisp")
  92                (html-escape (parse-docstrings:get-string lisp))))
  93
  94 (defmethod format-doc (stream
  95                        (list parse-docstrings:itemization)
  96                        (format (eql :html)))
  97   (with-html (stream :ul '(:class "itemization"))
  98     (dolist (item (parse-docstrings:get-items list))
  99       (with-html (stream :li '(:class "item"))
 100         (format-html-item stream item)))))
 101
 102 (defgeneric format-html-item (stream item))
 103
 104 (defmethod format-html-item (stream item)
 105   (format-doc stream item :html))
 106
 107 (defmethod format-html-item (stream (item parse-docstrings:section))
 108   (dolist (b (parse-docstrings:get-blocks item))
 109     (format-doc stream b :html)))
 110
 111 (defmethod format-doc (stream
 112                        (section parse-docstrings:section)
 113                        (format (eql :html)))
 114   (dolist (b (parse-docstrings:get-blocks section))
 115     (format-doc stream b format)))
 116
 117 (defmethod format-doc (stream
 118                        (paragraph parse-docstrings:paragraph)
 119                        (format (eql :html)))
 120   (format-html stream
 121                :p
 122                '()
 123                (html-text (parse-docstrings:get-string paragraph))))
 124
 125 (defmethod format-doc (stream
 126                        (tabulation parse-docstrings:tabulation)
 127                        (format (eql :html)))
 128   (with-html (stream :dl '(:class "tabulation"))
 129     (dolist (i (parse-docstrings:get-items tabulation))
 130       (format-doc stream i format))))
 131
 132 (defmethod format-doc (stream
 133                        (item parse-docstrings:tabulation-item)
 134                        (format (eql :html)))
 135   (format-html stream :dt
 136                '(:class "tabulation-title")
 137                (html-escape (parse-docstrings:get-title item)))
 138   (with-html (stream :dd '(:class "tabulation-body"))
 139     (format-html-item stream (parse-docstrings:get-body item))))