++ +
Abstract
This +is a quick hack which helps to build HTML pages that look +like this one or like +the one you're currently looking at. It hasn't been tested +thoroughly, it isn't properly documented, it only works +with LispWorks, +SBCL, and AllegroCL, and it most likely doesn't do +what you expect. ++The code comes with +a BSD-style +license so you can basically do with it whatever you want. + +
+Download shortcut: http://weitz.de/files/documentation-template.tar.gz. +
+If you want to send patches, please read this first.
+
+
[Function]
create-template package &key target maybe-skip-methods-p subtitle if-exists if-does-not-exist => result
+
+ + + + + +
+ +Writes an HTML page with preliminary documentation entries and +an index for all exported symbols of the packagepackageto the +filetarget. +Ifmaybe-skip-methods-pis true, documentation entries for +inidividual methods are skipped if the corresponding generic function +has a documentation string + +
[Special variable]
*target*
+
+ + + +
+ +Where to output the HTML page. If this value is notNIL, it will +be the default target forCREATE-TEMPLATE.CREATE-TEMPLATEwill also +set this value. + +
[Special variable]
*maybe-skip-methods-p*
+
+ + +
+ +This is the default value for the:MAYBE-SKIP-METHODS-Pkeyword +argument ofCREATE-TEMPLATEand its initial value isNIL. +
+This documentation was prepared with, you guessed it, DOCUMENTATION-TEMPLATE. Thanks to Michael Weber for the SBCL patches and to Willem Broekema for the AllegroCL patches. +
++$Header: /usr/local/cvsrep/documentation-template/doc/index.html,v 1.12 2008/05/29 08:22:26 edi Exp $ +
BACK TO MY HOMEPAGE + + + addfile ./documentation-template.asd hunk ./documentation-template.asd 1 - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/documentation-template/documentation-template.asd,v 1.11 2008/05/29 08:23:37 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :documentation-template-asd + (:use :cl :asdf)) + +(in-package :documentation-template-asd) + +#+:sbcl +(require :sb-introspect) + +(asdf:defsystem :documentation-template + :serial t + :version "0.4.1" + :components ((:file "packages") + (:file "specials") + (:file "util") + (:file "output")) + :depends-on (:cl-who)) addfile ./output.lisp hunk ./output.lisp 1 - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DOCUMENTATION-TEMPLATE; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/documentation-template/output.lisp,v 1.14 2008/05/29 08:23:37 edi Exp $ + +;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :documentation-template) + +(defun write-entry-header (name type &key (write-name-p t)) + "Writes the header for a documentation entry of name NAME and +type TYPE. The HTML anchor will only get a 'name' attribute if +WRITE-NAME-P is true and NAME is not a SETF name." + (format t "~%~%~%~%
[~A]
"
+ name type (and write-name-p (atom name) (string-downcase name))))
+
+(defun write-entry-footer (name doc-string)
+ "Writes the footer for a documentation entry for the name NAME
+including the documentation string DOC-STRING."
+ (format t "~%
~%~%~%"
+ (and doc-string (escape-string-iso-8859 doc-string)) name))
+
+(defun write-constant-entry (symbol doc-string)
+ "Writes a full documentation entry for the constant SYMBOL."
+ (write-entry-header symbol "Constant")
+ (format t "~A" (string-downcase symbol))
+ (write-entry-footer symbol doc-string))
+
+(defun write-special-var-entry (symbol doc-string)
+ "Writes a full documentation entry for the special variable
+SYMBOL."
+ (write-entry-header symbol "Special variable")
+ (format t "~A" (string-downcase symbol))
+ (write-entry-footer symbol doc-string))
+
+(defun write-class-entry (symbol doc-string)
+ "Writes a full documentation entry for the class SYMBOL."
+ (write-entry-header symbol (if (subtypep symbol 'condition)
+ "Condition type" "Standard class"))
+
+ (format t "~A" (string-downcase symbol))
+ (write-entry-footer symbol doc-string))
+
+(defun write-lambda-list* (lambda-list &optional specializers)
+ "The function which does all the work for WRITE-LAMBDA-LIST and
+calls itself recursive if needed."
+ (let (body-seen after-required-args-p (firstp t))
+ (dolist (part lambda-list)
+ (cond (body-seen (setq body-seen nil))
+ (t (when (and (consp part) after-required-args-p)
+ (setq part (first part)))
+ (unless firstp
+ (write-char #\Space))
+ (setq firstp nil)
+ (cond ((consp part)
+ ;; a destructuring lambda list - recurse
+ (write-char #\()
+ (write-lambda-list* part)
+ (write-char #\)))
+ ((member part '(&key &optional &rest &allow-other-keys &aux &environment &whole))
+ ;; marks these between and
+ (setq after-required-args-p t)
+ (format t "~A" (escape-string (string-downcase part))))
+ ((eq part '&body)
+ ;; we don't really write '&BODY', we write it
+ ;; like in the CLHS
+ (setq body-seen t
+ after-required-args-p t)
+ (write-string "declaration* statement*"))
+ (t
+ (let ((specializer (pop specializers)))
+ (cond ((and specializer (not (eq specializer t)))
+ ;; add specializers if there are any left
+ (write-string (escape-string
+ (string-downcase
+ (format nil "(~A ~A)" part specializer)))))
+ (t (write-string (escape-string (string-downcase part)))))))))))))
+
+(defun write-lambda-list (lambda-list &key (resultp t) specializers)
+ "Writes the lambda list LAMBDA-LIST, optionally with the
+specializers SPECIALIZERS. Adds something like `=> result' at
+the end if RESULTP is true."
+ (write-string "")
+ (write-lambda-list* lambda-list specializers)
+ (write-string "")
+ (when resultp
+ (write-string " => result")))
+
+(defun write-macro-entry (symbol lambda-list doc-string)
+ "Writes a full documentation entry for the macro SYMBOL."
+ (write-entry-header symbol "Macro")
+ (format t "~A " (string-downcase symbol))
+ (write-lambda-list lambda-list)
+ (write-entry-footer symbol doc-string))
+
+(defun write-function-entry (name lambda-list doc-string other-entries
+ &key genericp signature-only-p specializers qualifiers)
+ "Writes a full documentation entry for the function, generic
+function, or method with name NAME. NAME is a generic function
+if GENERICP is true, SPECIALIZERS is a list of specializers,
+i.e. in this case NAME is a method. Likewise, QUALIFIERS is a
+list of qualifiers. SIGNATURE-ONLY-P means that we don't want a
+full header."
+ (let* ((setfp (consp name))
+ (symbol (if setfp (second name) name))
+ (type (cond (specializers :method)
+ (genericp :generic-function)
+ (t :function)))
+ ;; check if this is a reader for which there is a writer (so
+ ;; we have an accessor) with the same signature
+ (writer (and (not setfp)
+ (find-if (lambda (entry)
+ (and (equal `(setf ,name) (first entry))
+ (eq type (second entry))
+ (or (null specializers)
+ (equal specializers (rest (fifth entry))))))
+ other-entries)))
+ (resultp (and (not setfp)
+ (null (intersection '(:before :after)
+ qualifiers)))))
+ (cond (signature-only-p
+ (write-string ""))
+ (t
+ (write-entry-header name (if writer
+ (ecase type
+ (:method "Specialized accessor")
+ (:generic-function "Generic accessor")
+ (:function "Accessor"))
+ (ecase type
+ (:method "Method")
+ (:generic-function "Generic function")
+ (:function "Function")))
+ :write-name-p (null specializers))))
+ (cond (setfp
+ (format t "(setf (~A " (string-downcase symbol))
+ (write-lambda-list (rest lambda-list) :resultp resultp :specializers (rest specializers))
+ (write-string ") ")
+ ;; we should use the specializer here as well
+ (format t "~A" (string-downcase (first lambda-list)))
+ (write-string ")")
+ (format t "~(~{ ~S~^~}~)" qualifiers))
+ (t (format t "~A " (string-downcase symbol))
+ (write-lambda-list lambda-list :specializers specializers :resultp resultp)
+ (format t "~(~{ ~S~^~}~)" qualifiers)))
+ (when writer
+ ;; if this is an accessor, the add the writer immediately after
+ ;; the reader..
+ (format t "~%
~%~%~@[~A~]~%~%
")
+ (destructuring-bind (name doc-type lambda-list doc-string &optional specializers qualifiers)
+ writer
+ (declare (ignore doc-type doc-string))
+ (write-function-entry name lambda-list nil nil
+ :signature-only-p t
+ :specializers specializers
+ :qualifiers qualifiers))
+ ;; ...and remove it from the list of entries which haven't been
+ ;; written yet
+ (setq other-entries (remove writer other-entries))))
+ (unless signature-only-p
+ (write-entry-footer name doc-string))
+ other-entries)
+
+(defun write-entry (entry other-entries)
+ "Write one documentation entry corresponding to ENTRY.
+OTHER-ENTRIES is the list of the remaining entries waiting to be
+written. OTHER-ENTRIES, probably updated, will be returned."
+ (destructuring-bind (name doc-type lambda-list doc-string &optional specializers qualifiers)
+ entry
+ (unless (or (consp name) specializers)
+ ;; add NAME to index list unless it's a SETF name or the name of
+ ;; a method
+ (push name *symbols*))
+ (ecase doc-type
+ (:constant (write-constant-entry name doc-string))
+ (:special-var (write-special-var-entry name doc-string))
+ (:class (write-class-entry name doc-string))
+ (:macro (write-macro-entry name lambda-list doc-string))
+ (:function (setq other-entries
+ (write-function-entry name lambda-list doc-string other-entries)))
+ (:generic-function (setq other-entries
+ (write-function-entry name lambda-list doc-string other-entries
+ :genericp t)))
+ (:method (setq other-entries
+ (write-function-entry name lambda-list doc-string other-entries
+ :specializers specializers
+ :qualifiers qualifiers)))))
+ other-entries)
+
+(defun write-page-header (package-name subtitle symbols)
+ "Writes the header of the HTML page. Assumes that the library
+has the same name as the package. Adds a list of all exported
+symbols with links."
+ (format t "
+
+
+
++ +
Abstract
+ +The code comes with +a BSD-style +license so you can basically do with it whatever you want. + ++Download shortcut: http://weitz.de/files/~:*~A.tar.gz. +
~:*~A
+~} +This documentation was prepared with DOCUMENTATION-TEMPLATE. +
++$Header: /usr/local/cvsrep/documentation-template/output.lisp,v 1.14 2008/05/29 08:23:37 edi Exp $ +
BACK TO MY HOMEPAGE
+
+
+"))
+
+(defun create-template (package &key (target (or *target*
+ #-:lispworks (error "*TARGET* not specified.")
+ #+:lispworks
+ (capi:prompt-for-file "Select an output target:"
+ :operation :save
+ :filters '("HTML Files" "*.HTML;*.HTM"
+ "All Files" "*.*")
+ :filter "*.HTML;*.HTM")))
+ (subtitle "a cool library")
+ ((:maybe-skip-methods-p *maybe-skip-methods-p*)
+ *maybe-skip-methods-p*)
+ (if-exists :supersede)
+ (if-does-not-exist :create))
+ "Writes an HTML page with preliminary documentation entries and an
+index for all exported symbols of the package PACKAGE to the file
+TARGET. If MAYBE-SKIP-METHODS-P is true, documentation entries for
+inidividual methods are skipped if the corresponding generic function
+has a documentation string."
+ (when target
+ (setq *target* target))
+ (let (*symbols*)
+ (with-open-file (*standard-output* target
+ :direction :output
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (let ((body
+ (with-output-to-string (*standard-output*)
+ (let ((entries (collect-all-doc-entries package)))
+ (loop
+ (let ((entry (or (pop entries) (return))))
+ (setq entries (write-entry entry entries))))))))
+ (write-page-header (package-name package) subtitle
+ (mapcar #'string-downcase (reverse *symbols*)))
+ (write-string body)
+ (write-page-footer))))
+ (values))
addfile ./packages.lisp
hunk ./packages.lisp 1
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/documentation-template/packages.lisp,v 1.9 2008/05/29 08:23:37 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :documentation-template
+ (:use :cl
+ :cl-who
+ #+:lispworks :clos
+ #+:sbcl :sb-mop
+ #+:allegro :mop)
+ #+:lispworks (:add-use-defaults t)
+ (:export :*maybe-skip-methods-p*
+ :*target*
+ :create-template))
addfile ./specials.lisp
hunk ./specials.lisp 1
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DOCUMENTATION-TEMPLATE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/documentation-template/specials.lisp,v 1.7 2008/05/29 08:23:37 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :documentation-template)
+
+(defvar *target* nil
+ "Where to output the HTML page. If this value is not NIL, it will
+be the default target for CREATE-TEMPLATE. CREATE-TEMPLATE will also
+set this value.")
+
+(defvar *maybe-skip-methods-p* nil
+ "This is the default value for the :MAYBE-SKIP-METHODS-P keyword
+argument of CREATE-TEMPLATE and its initial value is NIL. It is also
+used internally.")
+
+(defvar *symbols* nil
+ "The list of symbols for which we will create an index with links.")
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see