[cldoc-cvs] CVS update: cldoc/src/cludg.lisp cldoc/src/html.lisp cldoc/src/package.lisp
Iban Hatchondo
ihatchondo at common-lisp.net
Thu Jan 5 14:47:15 UTC 2006
Update of /project/cldoc/cvsroot/cldoc/src
In directory common-lisp.net:/tmp/cvs-serv31239
Modified Files:
cludg.lisp html.lisp package.lisp
Log Message:
Fix Cody Koeninger bug: NIL is an acceptable value for dest-dir arg in extract-documentation (html.lisp); and clean up.
Date: Thu Jan 5 15:47:12 2006
Author: ihatchondo
Index: cldoc/src/cludg.lisp
diff -u cldoc/src/cludg.lisp:1.3 cldoc/src/cludg.lisp:1.4
--- cldoc/src/cludg.lisp:1.3 Thu Dec 15 01:55:27 2005
+++ cldoc/src/cludg.lisp Thu Jan 5 15:47:11 2006
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*-
-;;; $Id: cludg.lisp,v 1.3 2005/12/15 00:55:27 ihatchondo Exp $
+;;; $Id: cludg.lisp,v 1.4 2006/01/05 14:47:11 ihatchondo Exp $
;;; ---------------------------------------------------------------------------
;;; Title: Common Lisp Universal Documentation Generator
;;; Created: 2005 10 23 12:30
@@ -867,12 +867,16 @@
(defmethod extract-documentation
((text (eql 'text)) dest-dir (system asdf:system) &rest rest)
(let ((files (get-asdf-system-files system)))
+ (unless (getf rest :path-prefix)
+ (setf (getf rest :path-prefix)
+ (namestring (asdf:component-relative-pathname system))))
(apply #'extract-documentation text dest-dir files rest)))
(defmethod extract-documentation ((text (eql 'text)) dest-dir files &rest rest)
(declare (ignorable text))
- (unless (char= (char dest-dir (1- (length dest-dir))) #\/)
- (setf dest-dir (concatenate 'string dest-dir "/")))
+ (cond ((not (stringp dest-dir)) (setf dest-dir "./"))
+ ((char/= (char dest-dir (1- (length dest-dir))) #\/)
+ (setf dest-dir (concatenate 'string dest-dir "/"))))
(ensure-directories-exist dest-dir)
(let ((path-prefix
(or (getf rest :path-prefix)
Index: cldoc/src/html.lisp
diff -u cldoc/src/html.lisp:1.5 cldoc/src/html.lisp:1.6
--- cldoc/src/html.lisp:1.5 Fri Dec 16 19:21:58 2005
+++ cldoc/src/html.lisp Thu Jan 5 15:47:11 2006
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*-
-;;; $Id: html.lisp,v 1.5 2005/12/16 18:21:58 ihatchondo Exp $
+;;; $Id: html.lisp,v 1.6 2006/01/05 14:47:11 ihatchondo Exp $
;;; ---------------------------------------------------------------------------
;;; Title: Common Lisp Universal Documentation Generator: HTML driver
;;; Created: 2005 10 23 2:30
@@ -135,16 +135,11 @@
(defmethod extract-documentation ((driver (eql 'html)) dest-dir
(system asdf:system)
&rest initargs &key &allow-other-keys)
- (declare (ignorable driver))
- (let ((pp (getf initargs :path-prefix)))
- (remf initargs :path-prefix)
- (let ((args (get-initargs initargs)))
- (make-html-doc
- (apply #'make-instance 'html :string-parser-initargs initargs args)
- (get-asdf-system-files system)
- :dest-dir dest-dir
- :path-prefix (or pp (namestring
- (asdf:component-relative-pathname system)))))))
+ (unless (getf initargs :path-prefix)
+ (setf (getf initargs :path-prefix)
+ (namestring (asdf:component-relative-pathname system))))
+ (let ((files (get-asdf-system-files system)))
+ (apply #'extract-documentation driver dest-dir files initargs)))
(defmethod extract-documentation ((driver (eql 'html)) dest-dir filenames
&rest initargs &key &allow-other-keys)
@@ -156,7 +151,7 @@
(apply #'make-instance 'html :string-parser-initargs initargs args)
filenames
:path-prefix (or pp (directory-namestring (or *load-truename* ".")))
- :dest-dir dest-dir))))
+ :dest-dir (or dest-dir ".")))))
;;;
@@ -342,26 +337,25 @@
((&key (divclass "defun") name arg-list type anchor) &body body)
"Presents lisp forms according to our html documentation template."
(with-gensym (hanchor args)
- `(progn
- (with-tag (:div ,(when divclass `(:class ,divclass)))
- (with-tag (:div ,(when divclass `(:class "defunsignatures")))
- (let ((,hanchor ,anchor))
- (when ,hanchor (with-tag (:a (:id ,hanchor)) "")))
- (with-tag (:table (:cellpadding 0 :cellspacing 0 :width "100%"))
- (with-tag (:colgroup (:span 3))
- (with-tag (:col (:width "0*")))
- (with-tag (:col (:width "1*")))
- (with-tag (:col (:width "0*"))))
- (with-tag (:tbody ())
- (with-tag (:tr ())
- (with-tag (:td (:class "symbol-name"))
- (html-write "~a " ,name))
- (with-tag (:td (:class "lambda-list"))
- (let ((,args ,arg-list))
- (when ,args (html-write "~a" ,args))))
- (with-tag (:td (:class "symbol-type"))
- (html-write " [~@(~a~)]" ,type))))))
- , at body))))
+ `(with-tag (:div ,(when divclass `(:class ,divclass)))
+ (with-tag (:div ,(when divclass `(:class "defunsignatures")))
+ (let ((,hanchor ,anchor))
+ (when ,hanchor (with-tag (:a (:id ,hanchor)) "")))
+ (with-tag (:table (:cellpadding 0 :cellspacing 0 :width "100%"))
+ (with-tag (:colgroup (:span 3))
+ (with-tag (:col (:width "0*")))
+ (with-tag (:col (:width "1*")))
+ (with-tag (:col (:width "0*"))))
+ (with-tag (:tbody ())
+ (with-tag (:tr ())
+ (with-tag (:td (:class "symbol-name"))
+ (html-write "~a " ,name))
+ (with-tag (:td (:class "lambda-list"))
+ (let ((,args ,arg-list))
+ (when ,args (html-write "~a" ,args))))
+ (with-tag (:td (:class "symbol-type"))
+ (html-write " [~@(~a~)]" ,type))))))
+ , at body)))
(defun make-footer ()
"Appends CLDOC link and generation date."
@@ -411,26 +405,25 @@
(defmacro with-index-header
((index hdriver dest-dir title &key (head-title title)) &body body)
- (with-gensym (ctype href f ttitle)
+ (with-gensym (href ttitle iindex ddir)
`(with-slots (filter css-pathname charset) ,hdriver
- (with-open-file (os ,index :direction :output :if-exists :supersede)
- (let ((*print-case* :downcase)
- (,ttitle ,title)
- (,f (enough-namestring (truename ,index) (truename ,dest-dir)))
- (,ctype (format nil "text/html; charset=~a" charset))
- (,href (namestring (make-pathname-relative
- :from (truename ,dest-dir)
- :to (truename css-pathname)))))
+ (let* ((*print-case* :downcase)
+ (,iindex ,index)
+ (,ddir ,dest-dir)
+ (,ttitle ,title)
+ (,href (make-pathname-relative
+ :from (truename ,ddir) :to (truename css-pathname))))
+ (with-open-file (os ,iindex :direction :output :if-exists :supersede)
(with-html-page
- (os :csshref ,href
- :content-type ,ctype
+ (os :csshref (namestring ,href)
+ :content-type (format nil "text/html; charset=~a" charset)
:head-title ,head-title
:nav-name ,ttitle
- :index (toc-path-from (pathname os) ,dest-dir))
+ :index (toc-path-from (pathname os) ,ddir))
(with-tag (:div (:class "cludg-index-body"))
(when ,ttitle (with-tag (:h2 ()) (html-write "~a~%" ,ttitle)))
- (with-tag (:div ()) , at body)))
- (format nil "~a" ,f))))))
+ (with-tag (:div ()) , at body))))
+ (enough-namestring (truename ,iindex) (truename ,ddir))))))
(defun make-abc-index-entry (filename &key char-code non-alphabetic)
(let* ((name (file-namestring filename))
@@ -672,49 +665,53 @@
This control string has no parameter.")
(defun resolve-link (symdesc strings)
- (let ((protocols '("http://" "ftp://"))
+ (let ((schemes '("http://" "ftp://"))
(file (meta-descriptor-file (lookup-meta-descriptor symdesc))))
- (if (loop for p in protocols when (starts-with (car strings) p)
- do (return T))
+ (if (some #'(lambda (scheme) (starts-with (first strings) scheme)) schemes)
(values T (format nil "~{~a~^ ~}" strings))
(multiple-value-bind (name package) (split-name (second strings))
(let ((href (lookup-meta-descriptor-href
name (first strings) package file)))
- (values T href name))))))
+ (when (values T href name)))))))
(defun format-doc (symdesc html-driver strings)
"Default documentation string formater. The Do What I Mean capabilities
are delegated to the create-doctree-from-string method of the doctree
protocol in coordination with with-tree-loop iterator to produced the
final output."
- (labels ((map-over-tree (tree)
- (with-tree-loop (element tree)
- (if (stringp element)
- (html-write "~a " element)
- (case (tree-tag element)
- (:keyword
- (with-tag (:span (:class "keyword"))
- (map-over-tree element)))
- (:hyper-link
- (let ((link '()))
- (with-tree-loop (e element) (push e link))
- (multiple-value-bind (found-p href name)
- (resolve-link symdesc (reverse link))
- (if (and found-p href)
- (with-tag (:a (:href href))
- (html-write (or name href)))
- ;; [FIXME] RETRIEVE THE LINK MARKERS !!!
- ;; No link can be created from the given
- ;; information. Maybe the author was not
- ;; thinking to a an hyper link, for this
- ;; reason the text will be outputed as
- ;; as it was initially found.
- (html-write "{~{~a~^ ~}}" (reverse link))))))
- (t (with-tag ((tree-tag element) ())
- (map-over-tree element))))))))
- (with-slots (string-parser-initargs) html-driver
- (map-over-tree (apply #'create-doctree-from-string
- 'doctree strings string-parser-initargs)))))
+ (with-slots ((spi string-parser-initargs)) html-driver
+ (let* ((link-delims (getf spi :link-delimiters +default-link-delimiters+))
+ (left-link-delim (first link-delims))
+ (right-link-delim (second link-delims)))
+ (labels ((map-over-tree (tree)
+ (with-tree-loop (element tree)
+ (if (stringp element)
+ (html-write "~a " element)
+ (case (tree-tag element)
+ (:keyword
+ (with-tag (:span (:class "keyword"))
+ (map-over-tree element)))
+ (:hyper-link
+ (let ((link '()))
+ (with-tree-loop (e element) (push e link))
+ (multiple-value-bind (found-p href name)
+ (resolve-link symdesc (reverse link))
+ (if (and found-p href)
+ (with-tag (:a (:href href))
+ (html-write (or name href)))
+ ;; No link can be created from the given
+ ;; information. Maybe the author was not
+ ;; thinking to an hyper link, for this
+ ;; reason the text will be outputed as
+ ;; it was initially found.
+ (html-write "~a~{~a~^ ~}~a"
+ left-link-delim
+ (reverse link)1
+ right-link-delim)))))
+ (t (with-tag ((tree-tag element) ())
+ (map-over-tree element))))))))
+ (map-over-tree
+ (apply #'create-doctree-from-string 'doctree strings spi))))))
(defun make-html-doc (hdriver filenames &key (dest-dir ".") path-prefix)
"Reads all files specified in filenames and extract their documentation
Index: cldoc/src/package.lisp
diff -u cldoc/src/package.lisp:1.1.1.1 cldoc/src/package.lisp:1.2
--- cldoc/src/package.lisp:1.1.1.1 Fri Nov 18 15:52:18 2005
+++ cldoc/src/package.lisp Thu Jan 5 15:47:11 2006
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*-
-;;; $Id: package.lisp,v 1.1.1.1 2005/11/18 14:52:18 ihatchondo Exp $
+;;; $Id: package.lisp,v 1.2 2006/01/05 14:47:11 ihatchondo Exp $
;;; ---------------------------------------------------------------------------
;;; Title: Common Lisp Universal Documentation Generator package definition
;;; Created: 2005 10 23 12:30
@@ -82,9 +82,9 @@
should be added to the DWIM:
- links. how ?
- Unlike Albert (http://albert.sourceforge.net/) it does not allow programmers
- to insert comments at the source code level which are incorporated into the
- generated documentation.
+ Unlike Albert, {http://albert.sourceforge.net} , it does not allow
+ programmers to insert comments at the source code level which are
+ incorporated into the generated documentation.
Its goal was not to produce a LispDoc ala JavaDoc but to create a simple
and easy way to take advantage of the Lisp documentation string. So instead
of copying and pasting it in some commentary section with extra special
More information about the Cldoc-cvs
mailing list