;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DOCUMENTATION-TEMPLATE; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/documentation-template/output.lisp,v 1.16 2008/06/01 21:26:20 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-constant-entry (symbol doc-string) "Writes a full documentation entry for the constant SYMBOL." (with-html-output (*doc-output* nil :indent 2) (:|clix:constant| :name (string-downcase symbol) (:|clix:description| (esc doc-string))))) (defun write-special-var-entry (symbol doc-string) "Writes a full documentation entry for the special variable SYMBOL." (with-html-output (*doc-output* nil :indent 2) (:|clix:special-variable| :name (string-downcase symbol) (:|clix:description| (esc doc-string))))) (defun write-class-entry (symbol doc-string) "Writes a full documentation entry for the class SYMBOL." (with-html-output (*doc-output* nil :indent 2) (cond ((subtypep symbol 'condition) (htm (:|clix:condition| :name (string-downcase symbol) (:|clix:description| (esc doc-string))))) (t (htm (:|clix:class| :name (string-downcase symbol) (:|clix:description| (esc doc-string)))))))) (defun write-lambda-list* (lambda-list &optional specializers) "The function which does all the work for WRITE-LAMBDA-LIST and calls itself recursively 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 *doc-output*)) (setq firstp nil) (cond ((consp part) ;; a destructuring lambda list - recurse (write-char #\( *doc-output*) (write-lambda-list* part) (write-char #\) *doc-output*)) ((member part '(&key &optional &rest &allow-other-keys &aux &environment &whole)) ;; marks these between and (setq after-required-args-p t) (with-html-output (*doc-output* nil :indent 2) (:|clix:lkw| (esc (subseq (string-downcase part) 1))))) ((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*" *doc-output*)) (t (let ((specializer (pop specializers))) (write-string (escape-string (string-downcase (cond ((and specializer (not (eq specializer t))) ;; add specializers if there are any left (format nil "(~A ~A)" part specializer)) (t part)))) *doc-output*))))))))) (defun write-lambda-list (lambda-list &key specializers qualifiers (resultp t)) "Writes the lambda list LAMBDA-LIST, optionally with the specializers SPECIALIZERS. Adds something like `=> result' at the end if RESULTP is true." (with-html-output (*doc-output* nil :indent 2) (:|clix:lambda-list| (write-lambda-list* lambda-list specializers) (dolist (qualifier qualifiers) (htm (:|clix:qualifier| (string-downcase qualifier))))) (when resultp (htm (:|clix:returns| "result"))))) (defun write-macro-entry (symbol lambda-list doc-string) "Writes a full documentation entry for the macro SYMBOL." (with-html-output (*doc-output* nil :indent 2) (:|clix:function| :macro "true" :name (string-downcase symbol) (write-lambda-list lambda-list) (:|clix:description| (esc doc-string))))) (defun write-function-entry (name lambda-list doc-string other-entries &key genericp 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." (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 (writer (with-html-output (*doc-output* nil :indent 2) (:|clix:accessor| :generic (and genericp "true") :specialized specializers :name (string-downcase symbol) (write-lambda-list lambda-list :specializers specializers :qualifiers qualifiers :resultp resultp) (:|clix:description| (esc doc-string)))) (setq other-entries (remove writer other-entries))) (t (with-html-output (*doc-output* nil :indent 2) (:|clix:function| :generic (and genericp "true") :specialized specializers :name (string-downcase symbol) (write-lambda-list lambda-list :specializers (if setfp (rest specializers) specializers) :qualifiers (if setfp (rest qualifiers) qualifiers) :resultp resultp) (:|clix:description| (esc 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 (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 create-template (package &key (target (or *target* #-:lispworks (error "*TARGET* not specified.") #+:lispworks (capi:prompt-for-file "Select an output target:" :operation :save :filters '("XML Files" "*.XML" "All Files" "*.*") :filter "*.XML"))) (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 XML file with documentation entries 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)) (with-open-file (*doc-output* target :direction :output :if-exists if-exists :if-does-not-exist if-does-not-exist) (setf (html-mode) :xml) (let ((*html-empty-tag-aware-p* nil) (package-name (package-name package))) (with-html-output (*doc-output* *doc-output* :prologue #.+clix-prologue+ :indent 2) (:|clix:documentation| :xmlns "http://www.w3.org/1999/xhtml" :|xmlns:clix| "http://bknr.net/clixdoc" (:|clix:title| (esc package-name) " - " (esc subtitle)) (:|clix:short-description| (esc subtitle)) (:h2 (esc package-name) " - " (esc subtitle)) (:blockquote (:|clix:chapter| :name "abstract" :title "Abstract") (:p "The code comes with a " (:a :href "http://www.opensource.org/licenses/bsd-license.php" "BSD-style license") " so you can basically do with it whatever you want.") (:p (:font :color "red" "Download shortcut:") (:a :href (format nil "http://weitz.de/files/~(~A~).tar.gz" package-name) (fmt "http://weitz.de/files/~(~A~).tar.gz" package-name)) ".")) (:|clix:chapter| :name "contents" :title "Contents") (:|clix:contents|) (:|clix:chapter| :name "dict" :title (format nil "The ~A dictionary" package-name) (let ((entries (collect-all-doc-entries package))) (loop (let ((entry (or (pop entries) (return)))) (setq entries (write-entry entry entries)))))) (:|clix:chapter| :name "index" :title "Symbol index" "Here are all exported symbols of the " (:code (str package-name)) " package in alphabetical order linked to their corresponding documentation entries:" (:|clix:index|)) (:|clix:chapter| :name "ack" :title "Acknowledgements" (:p "This documentation was prepared with " (:a :href "http://weitz.de/documentation-template/" "DOCUMENTATION-TEMPLATE"))) (:p "$Header: /usr/local/cvsrep/documentation-template/output.lisp,v 1.16 2008/06/01 21:26:20 edi Exp $") (:p (:a :href "http://weitz.de/index.html" "BACK TO MY HOMEPAGE")))))) (values))