From ihatchondo at common-lisp.net Thu Dec 15 00:55:29 2005 From: ihatchondo at common-lisp.net (Iban Hatchondo) Date: Thu, 15 Dec 2005 01:55:29 +0100 (CET) Subject: [cldoc-cvs] CVS update: cldoc/src/cache-system.lisp cldoc/src/cludg.lisp cldoc/src/doc-cludg.lisp cldoc/src/html.lisp cldoc/src/string-parser.lisp Message-ID: <20051215005529.29FE188565@common-lisp.net> Update of /project/cldoc/cvsroot/cldoc/src In directory common-lisp.net:/tmp/cvs-serv8334 Modified Files: cache-system.lisp cludg.lisp doc-cludg.lisp html.lisp string-parser.lisp Log Message: - Fix bug in cludg.lisp that prevent function like (defun foo (bar) (declare (type fixnum bar)) bar) to be parsed. - lambda list and string purger has been rewrote. - added two features: - hyper link handling - sections like in the Hyperspec Date: Thu Dec 15 01:55:27 2005 Author: ihatchondo Index: cldoc/src/cache-system.lisp diff -u cldoc/src/cache-system.lisp:1.1.1.1 cldoc/src/cache-system.lisp:1.2 --- cldoc/src/cache-system.lisp:1.1.1.1 Fri Nov 18 15:52:17 2005 +++ cldoc/src/cache-system.lisp Thu Dec 15 01:55:27 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: cache-system.lisp,v 1.1.1.1 2005/11/18 14:52:17 ihatchondo Exp $ +;;; $Id: cache-system.lisp,v 1.2 2005/12/15 00:55:27 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator cache system ;;; Created: 2005 10 23 12:30 @@ -70,30 +70,34 @@ "Returns the meta-descriptor structure if any that holds a symbol-descriptor that is eq to desc if desc if a symbol-descriptor object. If desc is a string that names a descriptor then the meta-descriptor that holds a - symbol-descriptor with name desc and type desc-type is returned. If package - is specified then the returned meta-descriptor must be located in the - specified package." + symbol-descriptor with name desc and type desc-type is returned. + If package is specified then the returned meta-descriptor must be located + in the specified package. + desc-type, if given can be a symbol specifying a class type or a string + that should be equal to the desc-type slot of the symbol descriptor holds + by the meta descriptor candidate." (declare (type (or string symbol-descriptor) desc)) (when (typep desc 'symbol-descriptor) (let ((meta-descriptor (gethash desc *descriptor->meta-decriptors*))) (return-from lookup-meta-descriptor meta-descriptor))) - (loop with found-p = nil - for hd in (gethash desc *name->meta-decriptors*) - unless (null hd) - when (typep (meta-descriptor-desc hd) desc-type) - when (or (not package) (belongs-p (meta-descriptor-desc hd) package)) - do (setf found-p t) (loop-finish) - finally (return (and found-p hd)))) + (flet ((type-p (sd type) + (if (stringp type) (string= (desc-type sd) type) (typep sd type)))) + (loop for md in (gethash desc *name->meta-decriptors*) + when (and md (type-p (meta-descriptor-desc md) desc-type)) + when (or (not package) (belongs-p (meta-descriptor-desc md) package)) + do (return-from lookup-meta-descriptor md)))) (defun lookup-meta-descriptor-anchor (desc &optional desc-type package) "Returns the meta anchor if any for the specified descriptor or named - descriptor if desc is a string." + descriptor if desc is a string. (see: {defun lookup-meta-descriptor} )" (let ((meta-desc (lookup-meta-descriptor desc desc-type package))) (when meta-desc (meta-descriptor-anchor meta-desc)))) (defun lookup-meta-descriptor-href (desc &optional desc-type package relative) "Returns the meta href if any that links the specified descriptor or named - descriptor if desc is a string." + descriptor if desc is a string. If relative is given, it must be a string + designator for a filename. The returned href will be computed relatively + to this filename. (see: {defun lookup-meta-descriptor} )." (let ((meta-desc (lookup-meta-descriptor desc desc-type package))) (when meta-desc (meta-descriptor-href meta-desc relative)))) Index: cldoc/src/cludg.lisp diff -u cldoc/src/cludg.lisp:1.2 cldoc/src/cludg.lisp:1.3 --- cldoc/src/cludg.lisp:1.2 Sun Nov 20 23:33:24 2005 +++ cldoc/src/cludg.lisp Thu Dec 15 01:55:27 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: cludg.lisp,v 1.2 2005/11/20 22:33:24 ihatchondo Exp $ +;;; $Id: cludg.lisp,v 1.3 2005/12/15 00:55:27 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator ;;; Created: 2005 10 23 12:30 @@ -102,7 +102,7 @@ "Returns the first string found in the given list of forms. NIL is returned if no string is found before the first non declare form." - (flet ((declare-p (form) (eq (car form) 'DECLARE))) + (flet ((declare-p (form) (and (listp form) (eq (car form) 'DECLARE)))) (loop for sub-form in forms until (or (stringp sub-form) (not (declare-p sub-form))) finally (return (and (stringp sub-form) sub-form))))) @@ -155,54 +155,61 @@ associated to the specified output-format." (gethash output-format *output-types*)) -(defmacro define-string-purger ((name) docstring &rest forms) - "Defines a function of one parameter, a string, that will purge - that string of any `dangerous' characters for your driver. - - name (symbol): the name of the defined string purger function. - - docstring (string): its documentation string. - - forms (list): a list of pair as follows: (character replacement-string)." - `(defun ,(intern (format nil "~a" name)) (string) - ,@(when docstring `(,docstring)) - (with-output-to-string (stream) - (loop for c across string - do (case c - ,@(loop for (char replacing-string) in forms - collect `(,char (format stream ,replacing-string))) - (t (format stream "~C" c))))))) - -(defmacro define-lambda-list-purger ((name string-purger) docstring &rest forms) - "Defines a function of one parameter, a lambda-list, that will purge - that lambda-list of any `dangerous' characters for your driver. - - name (symbol): the name of the defined lambda-list purger function. - - string-purger (symbol): the name of function for purging strings. - - docstring (string): its documentation string. - - forms (list): a list of pair as follows: (symbol replacement-string). - The symbols are the Common Lisp symbols that might occures in - lambda-list." - `(defun ,(intern (format nil "~a" name)) (lambda-list) - ,@(when docstring `(,docstring)) - (flet ((starts-with-sharp-or-quote (form) - (let ((char0 (char (format nil "~s" form) 0))) - (or (char= #\# char0) (char= #\' char0))))) - (with-output-to-string (result) - (loop with eos = (gensym) - with string = (format nil "~{~s~^ ~}" lambda-list) - for (sym pos) = (multiple-value-list - (read-from-string - string nil eos :start (or pos 0))) - until (eq eos sym) - do (cond - ,@(loop for (symbol replacement-string) in forms collect - `((eq sym ',symbol) - (format result ,replacement-string))) - ((and (listp sym) (not (starts-with-sharp-or-quote sym))) - (format result "(~a)~:[ ~;~]" - (,(intern (format nil "~a" name)) sym) - (= pos (length string)))) - (t (format result "~a~:[ ~;~]" - (,(intern (format nil "~a" string-purger)) - (format nil "~s" sym)) - (= pos (length string)))))))))) +(defmacro remap-char (char stream &rest clauses) + ;; macro helper for define-purgers. + `(case ,char + ,@(loop for (c replace-string) in clauses + collect `(,c (format ,stream ,replace-string))) + (t (format ,stream "~C" ,char)))) + +(defmacro define-purgers (&key string-purger lambda-list-purger) + "Defines two functions of one parameter to purge from dangerous characters: + - :string-purger (name clauses &rest options): + Defines a function of one parameter, a string, that will purge + that string of any `dangerous' characters for your driver. + -- name (symbol): the name of the defined string purger function. + -- clauses (list): a list of pair as: (character replacement-string). + -- options (list): supported options: (:documentation string). + - :lambda-list-purger (name clauses &rest options): + Defines a function of one parameter, a lambda-list, that will purge + that lambda-list of any `dangerous' characters for your driver. + -- name (symbol): the name of the defined lambda-list purger function. + -- clauses (list): a list of pair as: (symbol replacement-string). + The symbols are the Common Lisp symbols that might occures in + lambda-list. + -- options (list): supported options: (:documentation string)." + (destructuring-bind (ll-purger ll-clauses &rest ll-options) lambda-list-purger + (destructuring-bind (s-purger sp-clauses &rest sp-options) string-purger + (let ((ll-doc (find :documentation ll-options :key #'car)) + (sp-doc (find :documentation sp-options :key #'car))) + `(progn + (defun ,(intern (format nil "~a" s-purger)) (string) + ,@(when sp-doc (cdr sp-doc)) + (with-output-to-string (stream) + (loop for c across string + do (remap-char c stream , at sp-clauses)))) + (defun ,(intern (format nil "~a" ll-purger)) (lambda-list) + ,@(when ll-doc (cdr ll-doc)) + (flet ((make-word () + (make-array 10 :adjustable t :fill-pointer 0 + :element-type 'character)) + (remap-word (word stream) + (when (> (length word) 0) + (cond + ,@(loop for (string replace-string) in ll-clauses + collect `((string-equal word ,string) + (format stream ,replace-string))) + (t (loop for c across word + do (remap-char c stream , at sp-clauses))))))) + (with-output-to-string (result) + (loop with word = (make-word) + for char across (format nil "~{~s~^ ~}" lambda-list) + if (member char '(#\( #\) #\Space) :test #'char=) + do (remap-word word result) + (remap-char char result , at sp-clauses) + (setf word (make-word)) + else do (vector-push-extend char word) + finally (remap-word word result)))))))))) (defmacro with-descriptor-read ((filespec descriptor) &body body) "with-descriptor-read uses open to create a file stream to file named by Index: cldoc/src/doc-cludg.lisp diff -u cldoc/src/doc-cludg.lisp:1.1.1.1 cldoc/src/doc-cludg.lisp:1.2 --- cldoc/src/doc-cludg.lisp:1.1.1.1 Fri Nov 18 15:52:18 2005 +++ cldoc/src/doc-cludg.lisp Thu Dec 15 01:55:27 2005 @@ -22,7 +22,7 @@ ;; Extract doc. -(cludg:extract-documentation 'cludg:html "/home/hatchond/src/Lisp/cludg/docu" +(cludg:extract-documentation 'cludg:html "../docu" (asdf:find-system :cldoc) ;;:filter #'cludg::default-filter :table-of-contents-title "Common Lisp Universal Documentation Generator") Index: cldoc/src/html.lisp diff -u cldoc/src/html.lisp:1.1.1.1 cldoc/src/html.lisp:1.2 --- cldoc/src/html.lisp:1.1.1.1 Fri Nov 18 15:52:18 2005 +++ cldoc/src/html.lisp Thu Dec 15 01:55:27 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: html.lisp,v 1.1.1.1 2005/11/18 14:52:18 ihatchondo Exp $ +;;; $Id: html.lisp,v 1.2 2005/12/15 00:55:27 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator: HTML driver ;;; Created: 2005 10 23 2:30 @@ -30,19 +30,12 @@ (register-output-type :html "html") (defclass html (driver) - ((doc-formater + ((string-parser-initargs :type list :initarg :string-parser-initargs) + (doc-formater :type function :initarg :doc-formater :initform #'format-doc :reader doc-formater) - (item-prefix-maker - :type function - :initarg :item-prefix-maker - :initform #'make-prefix) - (code-prefix - :type string - :initform ";;; " - :initarg :code-prefix) (filter :type (or null function) :initarg :filter @@ -86,31 +79,9 @@ output the strings, using the html machinery. The default doc-formater has some simple DWIM (Do What I Mean) capabilities. It recognizes both indent and empty-line paragraph breaks, - and bulleted lists. - For bulleted lists the grammar can be specified using the - :item-prefix-maker option of the driver. To end itemized list, just add - a blank line after the last item. The depth of bulleted lists is not - constrained, but if you start sub bulleted list then a blank line will - end the current one and all parents at the same time. Otherwise said, - like here, no other paragraph will be permitted in this item after the - sub list items. - The sublists item designator will obey to the following grammar unless - you have specified your own grammar (see the :item-prefix-maker option): - -- (-- ) is the second level of item sublist. - -- (--- ) is the third level of item sublist and so on. - - :item-prefix-maker (function): a designator for a function of one - argument. Its argument will be an (integer 1 *) that represents the - depth of the list. The return value is the corresponding string prefix - designator for bulleted list (sublist) items of the specified depth. - - :code-prefix (string): a string that designates a prefix for code snipet - insertion in the documentation string. It must prefix all lines of code - in the documentation string. The default value is: ';;; '. - For exemple: - ;;; (defun cludg-sample (bar) - ;;; \"How to prefix code snipet in the documentation string: - ;;; ;;; (setf *print-case* :downcase) - ;;; You are, of course, not limited to one line snipet.\" - ;;; (do-nothing)) + bulleted lists, code sample, hyper link and sections (like in the + Hyperspec). The default {defun format-doc} function delegates the + DWIM capabilities to the {defclass doctree} class. - :filter (or null function): a designator for a function of one argument. Its argument will be a symbol-descriptor object. The symbol-descriptor will be outputted if and only if this function returns NIL. @@ -133,6 +104,9 @@ the file delivered with CLDOC will simply be copied into the output directory (see :css-pathname). + All the options supported by the {defclass doctree} class are supported + when passed to the {defgeneric extract-documentation} method. + To localise the automatic documentation , if your documentation strings are not in english, the default generation language, you have to modify the following variables: @@ -147,29 +121,42 @@ - *printer-control-string* - *constructor-control-string*")) +(defun get-initargs + (initargs &optional (default-initargs + '(:copy-css-into-output-dir :filter :sort-predicate + :charset :table-of-contents-title :doc-formater + :css-pathname))) + (loop with foo = (gensym) + for initarg in default-initargs + for value = (getf initargs initarg foo) + unless (eq value foo) do (remf initargs initarg) + and collect initarg and collect value)) + (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) - (make-html-doc - (apply #'make-instance 'html initargs) - (get-asdf-system-files system) - :dest-dir dest-dir - :path-prefix (or pp (namestring - (asdf:component-relative-pathname system)))))) + (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))))))) (defmethod extract-documentation ((driver (eql 'html)) dest-dir filenames &rest initargs &key &allow-other-keys) (declare (ignorable driver)) (let ((pp (getf initargs :path-prefix))) (remf initargs :path-prefix) - (make-html-doc - (apply #'make-instance 'html initargs) - filenames - :dest-dir dest-dir - :path-prefix (or pp (directory-namestring (or *load-truename* ".")))))) + (let ((args (get-initargs initargs))) + (make-html-doc + (apply #'make-instance 'html :string-parser-initargs initargs args) + filenames + :path-prefix (or pp (directory-namestring (or *load-truename* "."))) + :dest-dir dest-dir)))) ;;; @@ -201,7 +188,7 @@ (defun default-filter (desc) "Returns true if the given symbol-descriptor is not an external symbol - of its package or if is a defmethod descriptor for which a defgenereric + of its package or if is a defmethod descriptor for which a defgeneric descriptor exists." (when (typep desc 'defpackage-descriptor) (return-from default-filter nil)) @@ -331,7 +318,7 @@ , at body (make-footer))))) -(defun htmlify-doc (&key doc-string (purge-p t) html-driver) +(defun htmlify-doc (desc &key (doc-string (doc desc)) (purge-p t) html-driver) "Presents the given doc-string according to our html template. - doc-string (string): the documentation string to write. - purge-p (boolean): If T the documentation string will be purged of @@ -340,6 +327,7 @@ (when (and doc-string (string/= doc-string "")) (with-tag (:div (:class "doc-body")) (funcall (doc-formater html-driver) + desc html-driver (mapcar #'(lambda (s) (if purge-p (purge-string-for-html s) s)) (grok-new-lines doc-string)))))) @@ -671,7 +659,18 @@ "Defstruct include indication control string for automatic documentation. This control string has no parameter.") -(defun format-doc (html-driver strings) +(defun resolve-link (symdesc strings) + (let ((protocols '("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)) + (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)))))) + +(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 @@ -681,14 +680,29 @@ (if (stringp element) (html-write "~a " element) (case (tree-tag element) - (:keyword (with-tag (:span (:class "keyword")) - (map-over-tree 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 ((ipm item-prefix-maker) (cp code-prefix)) html-driver - (map-over-tree - (create-doctree-from-string - 'doctree strings :prefix-maker ipm :code-prefix cp))))) + (with-slots (string-parser-initargs) html-driver + (map-over-tree (apply #'create-doctree-from-string + 'doctree strings string-parser-initargs))))) (defun make-html-doc (hdriver filenames &key (dest-dir ".") path-prefix) "Reads all files specified in filenames and extract their documentation @@ -741,25 +755,27 @@ ;;; Purger. ;;; -(define-string-purger (purge-string-for-html) - "Tries to purge a string from characters that are potentially - dangerous for HTML." - (#\& "&") - (#\" """) - (#\< "<") - (#\> ">")) - -(define-lambda-list-purger (purge-lambda-list-for-html purge-string-for-html) - "Tries to purge a lambda-list from characters that are potentially - dangerous for HTML." - (&key "&key ") - (&optional "&optional ") - (&rest "&rest ") - (&allow-other-keys "&allow-other-keys ") - (&body "&body ") - (&aux "&aux ") - (&environment "&environment ") - (&whole "&whole ")) +(define-purgers + :string-purger + (purge-string-for-html + ((#\& "&") + (#\" """) + (#\< "<") + (#\> ">")) + (:documentation "Tries to purge a string from characters that + are potentially dangerous for HTML.")) + :lambda-list-purger + (purge-lambda-list-for-html + (("&key" "&key") + ("&optional" "&optional") + ("&rest" "&rest") + ("&allow-other-keys" "&allow-other-keys") + ("&body" "&body") + ("&aux" "&aux") + ("&environment" "&environment") + ("&whole" "&whole")) + (:documentation "Tries to purge a lambda-list from characters that are + potentially dangerous for HTML."))) ;;; ;;; Misc. @@ -829,11 +845,11 @@ (defmethod dformat-documentation (desc (driver html) stream) (declare (ignorable stream)) - (htmlify-doc :doc-string (doc desc) :html-driver driver)) + (htmlify-doc desc :html-driver driver)) (defmethod dformat-documentation ((desc structured-object-descriptor) (driver html) os) - (htmlify-doc :doc-string (doc desc) :html-driver driver) + (htmlify-doc desc :html-driver driver) (when (slots desc) (with-tag (:div (:class "defclass-initargs")) (loop for slot in (slots desc) @@ -854,8 +870,7 @@ (defmethod dformat ((desc in-package-form) (driver html) os) (declare (ignorable driver os desc)) - ;;(setf *current-package* (dest-package desc)) - ) + (setf *current-package* (dest-package desc))) (defmethod dformat ((desc defpackage-descriptor) (driver html) os) (with-html-description Index: cldoc/src/string-parser.lisp diff -u cldoc/src/string-parser.lisp:1.1.1.1 cldoc/src/string-parser.lisp:1.2 --- cldoc/src/string-parser.lisp:1.1.1.1 Fri Nov 18 15:52:18 2005 +++ cldoc/src/string-parser.lisp Thu Dec 15 01:55:27 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: string-parser.lisp,v 1.1.1.1 2005/11/18 14:52:18 ihatchondo Exp $ +;;; $Id: string-parser.lisp,v 1.2 2005/12/15 00:55:27 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator: doc string parser ;;; Created: 2005 10 23 23:30 @@ -19,28 +19,109 @@ ;;; Protocol & definitions. +(defconstant +default-link-delimiters+ '(#\{ #\})) +(defconstant +default-section-prefix+ "* ") +(defconstant +default-code-prefix+ ";;; ") +(defconstant +default-section-names+ + '("Arguments and Values:" "Side Effects:" "Affected By:" + "Exceptional Situations:" "See Also:" "Notes:")) + (defclass doctree () ((tree :initform (make-tree :doc) :type array) (bulleted-list-opened-p :initform nil :type boolean) (bulleted-list-level :initform 0 :type fixnum) (last-line :initform nil :type (or null string)) + (section-prefix + :initform +default-section-prefix+ + :type string + :initarg :section-prefix + :reader section-prefix) + (section-names + :initform +default-section-names+ + :type list + :initarg :section-names + :reader section-names) + (link-delimiters + :initform +default-link-delimiters+ + :type list + :initarg :link-delimiters) (code-prefix + :initform +default-code-prefix+ + :type string :initarg :code-prefix - :initform ";;; " - :reader code-prefix - :type string) - (prefix-maker - :initform #'make-prefix - :initarg :prefix-maker - :type function)) + :reader code-prefix) + (item-prefix-maker + :initform #'make-item-prefix + :type function + :initarg :item-prefix-maker)) (:documentation "This class will be used to represent the doc string structure. Context such as paragraph and bulleted list will be repesented as vector block. This is used to retreive the context - the documentation writer has indicated by its 'Do What I Mean' block.")) + the documentation writer has indicated by its 'Do What I Mean' block. + It recognizes both indent and empty-line paragraph breaks, bulleted lists, + code sample, hyper link and sections (like in the Hyperspec). + + For bulleted lists the grammar can be specified using the + :item-prefix-maker option of the driver. To end itemized list, just add + a blank line after the last item. The depth of bulleted lists is not + constrained, but if you start sub bulleted list then a blank line will + end the current one and all parents at the same time. Otherwise said, + like here, no other paragraph will be permitted in an item after its + sub list items. + The sublists item designator will obey to the following grammar unless + you have specified your own grammar (see the :item-prefix-maker option): + - (- ) is the first level of list item prefix. + - (-- ) is the second level of list item prefix. + - (--- ) is the third level of list item prefix and so on. + + Use the following options to customize the parser: + - :item-prefix-maker (function): a designator for a function of one + argument. Its argument will be an (integer 1 *) that represents the + depth of the list. The return value is the corresponding string prefix + designator for bulleted list (sublist) items of the specified depth. + - :code-prefix (string): a string that designates a prefix for code snipet + insertion in the documentation string. It must prefix all lines of code + in the documentation string. + The default value is: {defconstant +default-code-prefix+} . + For exemple: + ;;; (defun cludg-sample (bar) + ;;; \"How to prefix code snipet in the documentation string: + ;;; ;;; (setf *print-case* :downcase) + ;;; You are, of course, not limited to one line snipet.\" + ;;; (do-nothing)) + - :section-prefix (string): a string that will be used to determine if a + section must be started or not if found at the beginning (ignoring left + whitespaces) of the line. The default value is: + {defconstant +default-section-prefix+} . + - :section-names (string list): a list of string indicating the section + names. This must be used in conjonction with the section-prefix. + For instance start a line as follows: '* See Also:'. Default value is: + {defconstant +default-section-names+} . + - :link-delimiters (list of two character): a list of two characters that + indicates the link opening and closing characters. Default value is: + {defconstant +default-link-delimiters+} . Link grammar: + [opening-char(URL | defun | defclass | ...)closing-char]. If the hyper + link can be resolved.")) (defgeneric doctree-tree (doctree) (:documentation "Returns the tree that represent this doctree instance.")) +(defgeneric link-delimiters (doctree) + (:documentation "Returns as a multiple value the left and right + characters that delimits a hyper link in a documentation string.")) + +(defgeneric link-found-p (doctree word words) + (:documentation "Returns T and the length (in words) if any hyper link is + found. An hyper link will be found if the first character of word is equal + to the specified doctree link-delimiters open-char and if any word of the + (word . words) ends with the specified doctree link-delimiters + closing-char.")) + +(defgeneric doc-section-p (doctree string) + (:documentation "If the doctre section prefix delimiter is a prefix of the + given string then returns as a multiple value the string without section + prefix delimiter, and the section name.")) + (defgeneric bulleted-list (doctree level) (:documentation "Returns the bulleted list of given level.")) @@ -54,6 +135,13 @@ This the place for word recognition ; with the default implemention lisp keyword will be recognized and added within a keyword subtree block.")) +(defgeneric add-section (doctree section-name string &optional tree) + (:documentation "Insert a section of title section-name in the specified + doctree-tree (or subtree if specified). Any opened paragraph will be closed + before. Then if the result of trimming the section-name of string result in + a non empty string then the remaining substring will be added in a newly + opened paragraph.")) + (defgeneric add-to-paragraph (doctree string &optional subtree) (:documentation "Insert the given string in the last paragraph of the doctree tree or in the subtree if given. A paragraph will opened when @@ -65,9 +153,10 @@ #\Space characters than the given one.")) (defgeneric add-to-code-block (doctree string &optional subtree) - (:documentation "If the given string starts with the code-prefix of - the specified doctree, then it will append in the last code-block - opened in the doctree-tree or in the subtree if given.")) + (:documentation "Insert the given string, after removing its code-prefix, + in the last code-block of the specified doctree (or subtree if specified). + A new code-block will be opened in the doctree, or in the subtree, if the + last block is not a code-block.")) (defgeneric add-to-bulleted-list-item (doctree string) (:documentation "Adds a string to the latest item of the latest most inner @@ -87,10 +176,17 @@ (:documentation "Returns the document tree represented by the given strings when parsed with some Do What I Mean functions.") (:method ((type (eql 'doctree)) strings - &key (prefix-maker #'make-prefix) (code-prefix ";;; ") + &key (item-prefix-maker #'make-item-prefix) + (code-prefix +default-code-prefix+) + (section-prefix +default-section-prefix+) + (section-names +default-section-names+) + (link-delimiters +default-link-delimiters+) &allow-other-keys) (let ((dtree (make-instance type - :prefix-maker prefix-maker + :link-delimiters link-delimiters + :section-prefix section-prefix + :section-names section-names + :item-prefix-maker item-prefix-maker :code-prefix code-prefix))) (loop for string in strings do (handle-string dtree string)) (doctree-tree dtree)))) @@ -104,14 +200,19 @@ (defun tree-add (element tree) "Adds the specified element in the given tree." - (vector-push-extend element tree)) + (vector-push-extend element tree) tree) -(defun make-prefix (depth) +(defun make-item-prefix (depth) "Returns the desired list item designator according to te given depth. The depth is an integer greater than zero - aka: (integer 1 *)." (declare (type (integer 1 *) depth)) (concatenate 'string (make-string depth :initial-element #\-) " ")) +(defun trim-left-spaces (string) + "Returns a substring of string, with all Tab and Space characters stripped + off the beginning." + (string-left-trim '(#\Tab #\Space) string)) + (defun trim-prefix (prefix string &key (replace-prefix t)) "Returns a new string that does not contain prefix anymore. Left white spaces will be ignored but kept. Prefix will be replace by as many space characters @@ -126,7 +227,7 @@ (defun starts-with (string prefix &optional ignore-left-whitespace-p) "Returns T if the designed string starts with the desired string prefix." - (when ignore-left-whitespace-p (setf string (string-left-trim " " string))) + (when ignore-left-whitespace-p (setf string (trim-left-spaces string))) (unless (< (length string) (length prefix)) (loop for i from 0 below (length prefix) unless (char= (char string i) (char prefix i)) @@ -176,13 +277,13 @@ "Returns T if the specified tree represent a block of code." (and (tree-p tree) (eq :pre (tree-tag tree)))) -(defun string-bulleted-item-p (string level prefix-maker) +(defun string-bulleted-item-p (string level item-prefix-maker) "Returns T if the given string starts with the bulleted list prefix of the specified level." (declare (type string string)) (declare (type fixnum level)) - (declare (type function prefix-maker)) - (starts-with string (funcall prefix-maker level) t)) + (declare (type function item-prefix-maker)) + (starts-with string (funcall item-prefix-maker level) t)) (defun close-paragraph (doctree) (setf (slot-value doctree 'last-line) nil)) @@ -206,29 +307,67 @@ (defmethod doctree-tree ((doctree doctree)) (slot-value doctree 'tree)) +(defmethod link-delimiters ((doctree doctree)) + (values-list (slot-value doctree 'link-delimiters))) + +(defmethod link-found-p ((doctree doctree) word words) + (multiple-value-bind (open-char closing-char) (link-delimiters doctree) + (flet ((close-mark-found-p (str) + (char= closing-char (char str (1- (length str)))))) + (cond ((char/= open-char (char word 0)) (values NIL 0)) + ((close-mark-found-p word) (values T 1)) + (t (loop for str in words and nb-items from 2 ; word + the rest ! + when (char= closing-char (char str (1- (length str)))) + do (return-from link-found-p (values T nb-items)))))))) + +(defmethod doc-section-p ((doctree doctree) string) + (when (starts-with string (section-prefix doctree) t) + (loop with substr = (trim-prefix (section-prefix doctree) string) + for section in (section-names doctree) + when (starts-with substr section t) + do (return-from doc-section-p (values substr section))))) + +(defmethod add-section + ((doctree doctree) section string &optional (tree (doctree-tree doctree))) + (let ((substr (trim-prefix section string :replace-prefix nil))) + (with-slots (bulleted-list-opened-p bulleted-list-level) doctree + (setf bulleted-list-opened-p (close-paragraph doctree) + bulleted-list-level 0) + (tree-add (tree-add section (make-tree :h4)) tree) + (unless (string= "" (trim-left-spaces substr)) + (add-to-paragraph doctree substr))))) + (defmethod add-to-code-block ((doctree doctree) string &optional (tree (doctree-tree doctree))) (let ((code-block (aref tree (1- (length tree))))) ;; Open a code block if the last element in the tree is not a code block. (unless (code-block-p code-block) - (setf code-block (make-tree :pre)) - (tree-add code-block tree) + (tree-add (setf code-block (make-tree :pre)) tree) (close-paragraph doctree)) (when (> (length code-block) 1) (tree-add *newline* code-block)) ;; Remove left white space characters before prefix. (tree-add - (trim-prefix (code-prefix doctree) (string-left-trim " " string)) + (trim-prefix (code-prefix doctree) (trim-left-spaces string)) code-block))) (defmethod paragraph-handle-line ((doctree doctree) string &optional (tree (doctree-tree doctree))) - (loop for word in (split string) for wl = (length word) + (loop with words = (split string) and link-length = 0 and link-found-p = nil + for word = (pop words) for wl = (length word) while word if (> wl 1) if (and (char= #\: (char word 0)) (char/= #\: (char word (1- wl)))) - do (let ((keyword (make-tree :keyword))) - (tree-add keyword tree) - (tree-add word keyword)) + ;; keyword found: add a :keyword block in tree + do (tree-add (tree-add word (make-tree :keyword)) tree) + else if (multiple-value-setq (link-found-p link-length) + (link-found-p doctree word words)) + ;; hyper link found => add an :hyper-link block in tree + do (loop with item = (make-tree :hyper-link) + for i from 1 to link-length + for part = (subseq word 1) then (pop words) + if (< i link-length) do (tree-add part item) + else do (tree-add (subseq part 0 (1- (length part))) item) + finally (tree-add item tree)) else do (tree-add word tree) else if (> wl 0) do (tree-add word tree)) (tree-add *newline* tree)) @@ -285,9 +424,10 @@ (aref tree (1- (length tree))))) (defmethod add-to-bulleted-list ((doctree doctree) string level) - (with-slots (bulleted-list-opened-p bulleted-list-level prefix-maker) doctree + (with-slots (bulleted-list-opened-p bulleted-list-level item-prefix-maker) + doctree (let ((btree (bulleted-list doctree level)) - (prefix (funcall prefix-maker level)) + (prefix (funcall item-prefix-maker level)) (item (make-tree :li))) ;; End last paragraph. (close-paragraph doctree) @@ -306,15 +446,21 @@ (add-to-paragraph doctree string last-item))))) (defmethod handle-string ((doctree doctree) string) - (with-slots (bulleted-list-opened-p bulleted-list-level prefix-maker tree) + (with-slots + (bulleted-list-opened-p bulleted-list-level item-prefix-maker tree) doctree + ;; Handle HyperSpec like sections if necessary. + (multiple-value-bind (str section-name) (doc-section-p doctree string) + (when section-name + (add-section doctree section-name str) + (return-from handle-string nil))) ;; Check if it is a bulleted item then add it to its list. (loop for level from (1+ bulleted-list-level) downto 1 - if (string-bulleted-item-p string level prefix-maker) + if (string-bulleted-item-p string level item-prefix-maker) do (add-to-bulleted-list doctree string level) (return-from handle-string nil)) ;; Else add to last bulleted item or to current para. (if bulleted-list-opened-p (add-to-bulleted-list-item doctree string) - ;;; Add to last paragraph. - (add-to-paragraph doctree string tree)))) + ;; Add to last paragraph. + (add-to-paragraph doctree string)))) From ihatchondo at common-lisp.net Thu Dec 15 01:07:59 2005 From: ihatchondo at common-lisp.net (Iban Hatchondo) Date: Thu, 15 Dec 2005 02:07:59 +0100 (CET) Subject: [cldoc-cvs] CVS update: public_html/index.html Message-ID: <20051215010759.D126888565@common-lisp.net> Update of /project/cldoc/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv9502 Modified Files: index.html Log Message: news Date: Thu Dec 15 02:07:59 2005 Author: ihatchondo Index: public_html/index.html diff -u public_html/index.html:1.2 public_html/index.html:1.3 --- public_html/index.html:1.2 Sat Nov 19 20:04:11 2005 +++ public_html/index.html Thu Dec 15 02:07:59 2005 @@ -78,6 +78,16 @@

+ NEWS: 2005-12-15 +

+ + + +

Quick links

@@ -93,13 +103,6 @@ class="menuItem">Lisp Lesser GPL

-
From ihatchondo at common-lisp.net Thu Dec 15 23:16:21 2005 From: ihatchondo at common-lisp.net (Iban Hatchondo) Date: Fri, 16 Dec 2005 00:16:21 +0100 (CET) Subject: [cldoc-cvs] CVS update: cldoc/src/html.lisp Message-ID: <20051215231621.BE90588570@common-lisp.net> Update of /project/cldoc/cvsroot/cldoc/src In directory common-lisp.net:/tmp/cvs-serv15404 Modified Files: html.lisp Log Message: Fix invalid call to some lookup functions whan nothing to lookup for because NIL is not a desc. And fix argument lambda list format glitches due to format directive that can be present. Date: Fri Dec 16 00:16:17 2005 Author: ihatchondo Index: cldoc/src/html.lisp diff -u cldoc/src/html.lisp:1.2 cldoc/src/html.lisp:1.3 --- cldoc/src/html.lisp:1.2 Thu Dec 15 01:55:27 2005 +++ cldoc/src/html.lisp Fri Dec 16 00:16:15 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: html.lisp,v 1.2 2005/12/15 00:55:27 ihatchondo Exp $ +;;; $Id: html.lisp,v 1.3 2005/12/15 23:16:15 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator: HTML driver ;;; Created: 2005 10 23 2:30 @@ -591,13 +591,14 @@ (html-write summary-title ))) (loop for desc in (desc-sort descs #'alphabetical-order) for mdesc = (lookup-meta-descriptor desc) + when mdesc do (with-tag (:tr (:class "table-row-color")) (with-tag (:td (:class "summary-name")) (with-tag (:a (:href (meta-descriptor-href mdesc :local))) (html-write (purge-string-for-html (name desc))))) (with-tag (:td (:class "summary")) (let ((string (funcall key desc))) - (when string (html-write string))))))))) + (when string (html-write "~a" string))))))))) (defun make-constant-summary (descs filter) "Creates a summary table for defconstant descriptors if any." From ihatchondo at common-lisp.net Fri Dec 16 10:30:11 2005 From: ihatchondo at common-lisp.net (Iban Hatchondo) Date: Fri, 16 Dec 2005 11:30:11 +0100 (CET) Subject: [cldoc-cvs] CVS update: cldoc/src/html.lisp Message-ID: <20051216103011.D432E88570@common-lisp.net> Update of /project/cldoc/cvsroot/cldoc/src In directory common-lisp.net:/tmp/cvs-serv1460 Modified Files: html.lisp Log Message: Fix defpackage issue: if no defpackage form have been parsed, for any reason, re-arrenge parsed descripor by packages anyway. Otherwise table of content might be empty. Date: Fri Dec 16 11:30:10 2005 Author: ihatchondo Index: cldoc/src/html.lisp diff -u cldoc/src/html.lisp:1.3 cldoc/src/html.lisp:1.4 --- cldoc/src/html.lisp:1.3 Fri Dec 16 00:16:15 2005 +++ cldoc/src/html.lisp Fri Dec 16 11:30:09 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: html.lisp,v 1.3 2005/12/15 23:16:15 ihatchondo Exp $ +;;; $Id: html.lisp,v 1.4 2005/12/16 10:30:09 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator: HTML driver ;;; Created: 2005 10 23 2:30 @@ -466,6 +466,10 @@ (defun write-index (filename dest-dir title html-driver meta-descriptors) (let ((na-anchor (format nil "~a" (gensym))) (index-file (namestring (merge-pathnames filename dest-dir)))) + ;; Remove defpackage-descriptor of the meta-descriptors if any. + (let ((desc (meta-descriptor-desc (car meta-descriptors)))) + (when (typep desc 'defpackage-descriptor) + (setf meta-descriptors (cdr meta-descriptors)))) (with-index-header (index-file html-driver dest-dir title) ;; generate a b c d ... links (loop for i from (char-code #\a) to (char-code #\z) @@ -524,10 +528,16 @@ for desc = (meta-descriptor-desc meta-desc) for add-p = (not (or (not filter) (funcall filter desc))) for pname = (dpackage desc) + ;; Search the meta-desc package-name entry if (and add-p (gethash pname package-table)) do (push meta-desc (gethash pname package-table)) + ;; Else search the meta-desc (string-upcase package-name) entry else if (and add-p (gethash (string-upcase pname) package-table)) - do (push meta-desc (gethash (string-upcase pname) package-table)))) + do (push meta-desc (gethash (string-upcase pname) package-table)) + ;; Else meta-desc package entry is not in the table. Lets create the + ;; entry and add the meta-desc if desc is not a defpackage-descriptor. + else if (and add-p (not (typep desc 'defpackage-descriptor))) + do (push meta-desc (gethash pname package-table)))) (defun make-indexes (dest-dir html-driver) "Creates package index files, global index and table of contents." @@ -550,9 +560,8 @@ (get-descriptors-by-package html-driver meta-descriptors package-table) ;; Write a descriptors index file for each package. (loop for key being each hash-key in package-table using (hash-value mds) - for meta-descs = (cdr (reverse mds)) for file = (format nil "~a-index.html" key) - for href = (write-index file dest-dir key html-driver meta-descs) + for href = (write-index file dest-dir key html-driver (reverse mds)) for files = (mapcar #'meta-descriptor-file (stable-sort mds #'< :key #'meta-descriptor-index)) do (push From ihatchondo at common-lisp.net Fri Dec 16 18:21:59 2005 From: ihatchondo at common-lisp.net (Iban Hatchondo) Date: Fri, 16 Dec 2005 19:21:59 +0100 (CET) Subject: [cldoc-cvs] CVS update: cldoc/src/html.lisp Message-ID: <20051216182159.C9BA688446@common-lisp.net> Update of /project/cldoc/cvsroot/cldoc/src In directory common-lisp.net:/tmp/cvs-serv6723 Modified Files: html.lisp Log Message: Clean up Date: Fri Dec 16 19:21:58 2005 Author: ihatchondo Index: cldoc/src/html.lisp diff -u cldoc/src/html.lisp:1.4 cldoc/src/html.lisp:1.5 --- cldoc/src/html.lisp:1.4 Fri Dec 16 11:30:09 2005 +++ cldoc/src/html.lisp Fri Dec 16 19:21:58 2005 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*- -;;; $Id: html.lisp,v 1.4 2005/12/16 10:30:09 ihatchondo Exp $ +;;; $Id: html.lisp,v 1.5 2005/12/16 18:21:58 ihatchondo Exp $ ;;; --------------------------------------------------------------------------- ;;; Title: Common Lisp Universal Documentation Generator: HTML driver ;;; Created: 2005 10 23 2:30 @@ -260,12 +260,17 @@ :to (mkout (car (elt list (1- index)))))))) (defun alphabetical-order (desc1 desc2) - "Returns true if the name of the first descriptor is inferior, in the - string-lessp sens." + "Returns true if the name of the first descriptor is lexicographicaly + inferior to the name of the second descriptor." (flet ((get-name (desc) (let ((name (name desc))) (if (starts-with name "(") (subseq name 1) name)))) - (string-lessp (get-name desc1) (get-name desc2)))) + (let ((name1 (get-name desc1)) + (name2 (get-name desc2))) + (if (alpha-char-p (char name1 0)) + (if (alpha-char-p (char name2 0)) (string-lessp name1 name2) T) + (unless (alpha-char-p (char name2 0)) + (string-lessp name1 name2)))))) ;;; ;;; Macros for HTML writing. @@ -295,8 +300,9 @@ `(let ((,os ,stream)) (format ,os "<~a~{~^ ~a=\"~a\"~}~:[~;/~]>~%" ,tagname (list , at attributes) ,(zerop (length body))) - , at body - ,@(unless (zerop (length body)) `((format ,os "~%" ,tagname)))))) + (prog1 (progn , at body) + ,@(unless (zerop (length body)) + `((format ,os "~%" ,tagname))))))) (defmacro with-html-page ((os &key csshref content-type head-title nav-name index prev next) @@ -436,32 +442,26 @@ (defun make-index-entry (meta-descriptors &key char-code non-alphabetic filter) (flet ((char-code-string () (format nil "~:@(~c~)..." (code-char char-code))) - (get-first-char (name) + (first-char-p (name char) (let ((c (char name 0))) - (if (char= c #\() (char name 1) c))) - (make-entry (name desc href) - (unless (and filter (funcall filter desc)) - (with-tag (:div (:class "index-entry")) - (with-tag (:a (:href href)) - (html-write "~a," (purge-string-for-html name))) - (with-tag (:em ()) - (html-write "~a" (html-printable-type desc))))))) + (char-equal char (if (char= c #\() (char name 1) c))))) (with-tag (:a (:id (format nil "_~a" (or char-code non-alphabetic)))) "") (with-tag (:div (:class "abc-entry")) (with-tag (:h3 ()) (html-write (if char-code (char-code-string) "non-alphabetic"))) - (loop for mdesc in meta-descriptors + (loop with entry = (and char-code (code-char char-code)) + for mdesc in meta-descriptors for desc = (meta-descriptor-desc mdesc) - for name = (name desc) - for char1 = (get-first-char name) - if char-code - do (cond ((char-equal (code-char char-code) char1) - (make-entry name desc (meta-descriptor-href mdesc))) - ((char-greaterp char1 (code-char char-code)) - (loop-finish))) - else if non-alphabetic - do (when (or (char-lessp char1 #\A) (char-greaterp char1 #\z)) - (make-entry name desc (meta-descriptor-href mdesc))))))) + if (or (and entry (first-char-p (name desc) entry)) non-alphabetic) + do (unless (and filter (funcall filter desc)) + (with-tag (:div (:class "index-entry")) + (with-tag (:a (:href (meta-descriptor-href mdesc))) + (html-write "~a," (purge-string-for-html (name desc)))) + (with-tag (:em ()) + (html-write "~a" (html-printable-type desc))))) + (pop meta-descriptors) + else do (loop-finish) + finally (return meta-descriptors))))) (defun write-index (filename dest-dir title html-driver meta-descriptors) (let ((na-anchor (format nil "~a" (gensym))) @@ -478,7 +478,9 @@ (make-abc-index-entry index-file :non-alphabetic na-anchor) ;; the index itself (loop for i from (char-code #\a) to (char-code #\z) - do (make-index-entry meta-descriptors :char-code i :filter filter)) + do (setf meta-descriptors + (make-index-entry + meta-descriptors :char-code i :filter filter))) ;; add non-alphabetic (make-index-entry meta-descriptors @@ -759,7 +761,7 @@ do (with-slots (name type) desc (unless (and filter (funcall filter desc)) (dformat desc hdriver os)))))))))) - *unhandled-forms*)) + (remove-duplicates *unhandled-forms*))) ;;; ;;; Purger.