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 ,@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 ,@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 ,@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 @@ ,@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 "<em>&key</em> ") - (&optional "<em>&optional</em> ") - (&rest "<em>&rest</em> ") - (&allow-other-keys "<em>&allow-other-keys</em> ") - (&body "<em>&body</em> ") - (&aux "<em>&aux</em> ") - (&environment "<em>&environment</em> ") - (&whole "<em>&whole</em> ")) +(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" "<em>&key</em>") + ("&optional" "<em>&optional</em>") + ("&rest" "<em>&rest</em>") + ("&allow-other-keys" "<em>&allow-other-keys</em>") + ("&body" "<em>&body</em>") + ("&aux" "<em>&aux</em>") + ("&environment" "<em>&environment</em>") + ("&whole" "<em>&whole</em>")) + (: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))))