writer-html.lisp

   1 ;;; -*- lisp; show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;;; Part of this software was originally written as docstrings.lisp in
   4 ;;;; SBCL, but is now part of the texinfo-docstrings project.  The file
   5 ;;;; docstrings.lisp was written by Rudi Schlatte <rudi@constantly.at>,
   6 ;;;; mangled by Nikodemus Siivola, turned into a stand-alone project by
   7 ;;;; Luis Oliveira.  SBCL is in the public domain and is provided with
   8 ;;;; absolutely no warranty.
   9
  10 ;;;; texinfo-docstrings is:
  11 ;;;;
  12 ;;;; Copyright (c) 2008 David Lichteblau:
  13 ;;;;
  14 ;;;; Permission is hereby granted, free of charge, to any person
  15 ;;;; obtaining a copy of this software and associated documentation
  16 ;;;; files (the "Software"), to deal in the Software without
  17 ;;;; restriction, including without limitation the rights to use, copy,
  18 ;;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  19 ;;;; of the Software, and to permit persons to whom the Software is
  20 ;;;; furnished to do so, subject to the following conditions:
  21 ;;;;
  22 ;;;; The above copyright notice and this permission notice shall be
  23 ;;;; included in all copies or substantial portions of the Software.
  24 ;;;;
  25 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  26 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  27 ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  28 ;;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  29 ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  30 ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  31 ;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  32 ;;;; DEALINGS IN THE SOFTWARE.
  33
  34 (in-package #:texinfo-docstrings)
  35
  36 (define-document-format :html "html")
  37
  38 ;;;; HTML OUTPUT
  39
  40 (defvar *html-indent* 0)
  41
  42 (defmacro with-html ((stream tag attributes) &body forms)
  43   (sb-int:once-only ((stream stream) (tag tag))
  44     `(progn
  45       (format ,stream "~vT<~(~A~)~{ ~(~A~)=~S~}>~%" *html-indent* ,tag ,attributes)
  46       (let ((*html-indent* (+ 2 *html-indent*)))
  47         ,@forms)
  48       (format ,stream "~vT</~(~A~)>~%" *html-indent* ,tag))))
  49
  50 (defmethod format-document-start (stream package (format (eql :html)))
  51   (write-line "<html>" stream)
  52   (with-html (stream :head nil)
  53     (format-html stream :link '(:rel "stylesheet" :type "text/css" :href "style.css") nil)
  54     (format-html stream :title nil (package-name package)))
  55   (write-line "<body>" stream)
  56   (format-html stream :h1 '(:class "package-name") (package-name package)))
  57
  58 (defmethod format-document-end (stream package (format (eql :html)))
  59   (write-line "</body></html>" stream))
  60
  61 (defun html-escape (string)
  62   (with-output-to-string (s)
  63     (loop for char across string
  64           do (case char
  65                (#\< (write-string "&lt;" s))
  66                (#\> (write-string "&gt;" s))
  67                (#\& (write-string "&amp;" s))
  68                (t   (write-char char s))))))
  69
  70 (defun format-html (stream tag attributes string)
  71   (format stream "~vT<~(~A~)~{ ~(~A~)=~S~}~:[>~;/>~]~@[~A~]~@[</~(~A~)>~]~%"
  72           *html-indent* tag attributes (not string) string (when string tag)))
  73
  74 (defun html-text (string)
  75   (with-output-to-string (result)
  76     (let ((last 0))
  77       (dolist (symbol/index (parse-docstrings.sbcl::locate-symbols string))
  78         (write-string (html-escape (subseq string last (first symbol/index))) result)
  79         (let ((symbol-name (apply #'subseq string symbol/index)))
  80           (format result "<var>~A</var>" (html-escape symbol-name)))
  81         (setf last (second symbol/index)))
  82       (write-string (html-escape (subseq string last)) result))))
  83
  84 (defmethod format-doc (stream (doc parse-docstrings:documentation*) format)
  85   (let ((name (html-escape (princ-to-string (parse-docstrings:get-name doc)))))
  86     (with-html (stream :div '(:class "item"))
  87       (with-html (stream :div '(:class "type"))
  88         (format-html stream :a (list :name name)
  89                      (html-escape (format nil "[~A]" (string-downcase (princ-to-string (parse-docstrings:get-kind doc)))))))
  90       (with-html (stream :div '(:class "signature"))
  91         (format-html stream :code '(:class "name") name)
  92         (let ((ll (parse-docstrings:lambda-list doc)))
  93           (when ll
  94             (with-html (stream :span '(:class "args"))
  95               (dolist (elt ll)
  96                 (labels ((markup-ll (elt)
  97                            (cond ((member elt lambda-list-keywords)
  98                                   (format-html stream :code '(:class "llkw") (html-escape (princ-to-string elt))))
  99                                  ((listp elt)
 100                                   (write-string "(" stream)
 101                                   (mapcar #'markup-ll elt)
 102                                   (write-string ")" stream))
 103                                  (t
 104                                   (format-html stream :var () (html-escape (string-downcase (princ-to-string elt))))))))
 105                   (markup-ll elt)))))))
 106       (with-html (stream :div '(:class "item-body"))
 107         (let ((content (parse-docstrings:get-content doc)))
 108           (format-doc stream content format)))))
 109   (terpri stream))
 110
 111 (defmethod format-doc (stream
 112                        (lisp parse-docstrings:lisp-block)
 113                        (format (eql :html)))
 114   (format-html stream
 115                :pre
 116                '(:class "lisp")
 117                (html-escape (parse-docstrings:get-string lisp))))
 118
 119 (defmethod format-doc (stream
 120                        (list parse-docstrings:itemization)
 121                        (format (eql :html)))
 122   (with-html (stream :ul '(:class "itemization"))
 123     (dolist (item (parse-docstrings:get-items list))
 124       (with-html (stream :li '(:class "item"))
 125         (format-html-item stream item)))))
 126
 127 (defgeneric format-html-item (stream item))
 128
 129 (defmethod format-html-item (stream item)
 130   (format-doc stream item :html))
 131
 132 (defmethod format-html-item (stream (item parse-docstrings:section))
 133   (dolist (b (parse-docstrings:get-blocks item))
 134     (format-doc stream b :html)))
 135
 136 (defmethod format-doc (stream
 137                        (section parse-docstrings:section)
 138                        (format (eql :html)))
 139   (dolist (b (parse-docstrings:get-blocks section))
 140     (format-doc stream b format)))
 141
 142 (defmethod format-doc (stream
 143                        (paragraph parse-docstrings:paragraph)
 144                        (format (eql :html)))
 145   (format-html stream
 146                :p
 147                '()
 148                (html-text (parse-docstrings:get-string paragraph))))
 149
 150 (defmethod format-doc (stream
 151                        (tabulation parse-docstrings:tabulation)
 152                        (format (eql :html)))
 153   (with-html (stream :dl '(:class "tabulation"))
 154     (dolist (i (parse-docstrings:get-items tabulation))
 155       (format-doc stream i format))))
 156
 157 (defmethod format-doc (stream
 158                        (item parse-docstrings:tabulation-item)
 159                        (format (eql :html)))
 160   (format-html stream :dt
 161                '(:class "tabulation-title")
 162                (html-escape (parse-docstrings:get-title item)))
 163   (with-html (stream :dd '(:class "tabulation-body"))
 164     (format-html-item stream (parse-docstrings:get-body item))))