From 051cb6928ce6c6db99331eda414eee0d826d96ae Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Sun, 14 Dec 2008 16:50:59 +0100 Subject: [PATCH] Fork: Keep texinfo-docstrings, remove parse-docstrings --- annotate-documentation.lisp | 101 ----------- annotation-plist.lisp | 109 ------------ classes.lisp | 202 ---------------------- package.lisp | 46 +---- parse-docstrings.lisp | 307 ---------------------------------- syntax-sbcl.lisp | 397 -------------------------------------------- texinfo-docstrings.asd | 7 +- 7 files changed, 6 insertions(+), 1163 deletions(-) delete mode 100644 annotate-documentation.lisp delete mode 100644 annotation-plist.lisp delete mode 100644 classes.lisp rewrite package.lisp (74%) delete mode 100644 parse-docstrings.lisp delete mode 100644 syntax-sbcl.lisp diff --git a/annotate-documentation.lisp b/annotate-documentation.lisp deleted file mode 100644 index 1b46ebb..0000000 --- a/annotate-documentation.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;;; Written by David Lichteblau. Released into the public domain; -;;; feel free to copy&paste this file into your own software. - -(in-package :parse-docstrings) ;change this line when copy&pasting - -;;; Macro ANNOTATE-DOCUMENTATION: -;;; -;;; This macro is purposely small and simple, so that users can -;;; copy&paste it easily. -;;; -;;; The intention is to allow annotations in user code, without requiring -;;; a compilation-time dependency of the user's system to ours. -;;; -;;; We should try to guarantee API stability and minimize changes to this -;;; function so that copy&pasted definitions of the macro don't have to -;;; change. -;;; -;;; The macro has been written using keywords, so that it can be put into -;;; any package. -;;; -;;; Known issue: -;;; For simplicity we store data in a plist of the symbol. -;;; This restricts us to objects that have a symbol as their name and that -;;; can be distinguished by the pair of name and doc-type. -;;; -;;; This works well for variables, named classes, and named functions, at -;;; least to the extent that our workaround for SETF functions is sufficient. -;;; -;;; However, we can't annotate all objects permissible as a first argument to -;;; the Common Lisp function :DOCUMENTATION using this method. -;;; In particular, users must annotate function names, not function objects. -;;; -;;; A possible solution in the future would be to store annotations in -;;; a global hash table using weak references. Since an approach based on -;;; weak-references would not be attractive as a small code snippet for -;;; copy&paste, we could offer two versions of this macro: The simple -;;; version below, and an exported fully-featured version in our system. -;;; That way only users with exotic annotation requirements would have to -;;; depend on our system. - -;;; [ Start of code for copy&paste ] - -(defmacro annotate-documentation - ((name doc-type &key (key :documentation-annotations)) &body body) - (if (and (consp name) (eq (car name) 'setf)) - `(annotate-documentation - (,(cadr name) ,doc-type :setf-documentation-annotations) - ,@body) - `(setf (getf (get ',name ,key) ',doc-type) ',body))) - -;;; [ End of code for copy&paste ] - - -#| Example: - -(annotate-documentation (annotate-documentation function) - (:argument name - "The name of a variable, function, or type." - "Either a symbol or a list of the for (setf SYMBOL).") - (:argument doc-type - "A symbol with the same meaning as the second argument to" - "Common Lisp's DOCUMENTATION function.") - (:argument body - "Lists of the form (key [string or symbol]*)") - "Records annotations for docstring. This macro allows function arguments - and return values to be documented separately from the function's docstring - itself. It also provides for cross-references between documentation - strings without a textual reference in the docstring. - - Permissible forms in the body are: - (:argument NAME DOCSTRING) - Stores DOCSTRING as the description for argument NAME. - - (:return-value DOCSTRING) - (:return-value NAME DOCSTRING) - Stores DOCSTRING as the description for a return value. - - (:condition NAME) - Documents that this function signals conditions of type NAME. - - (:constructor NAME) - Documents that fresh instances of this class are returned by the - function NAME. - - (:slot-accessor NAME) - Documents that this class has a slot accessible through the function - NAME, and possibly settable through (setf name). - - Most useful for programs that opt not to document slots, and prefer - to document the slot accessors as ordinary functions instead. - - (:see-also-function NAME) - Adds a simple cross reference to a related function NAME. - - (:see-also-variable NAME) - Adds a simple cross reference to a related variable NAME. - - (:see-also-type NAME) - Adds a simple cross reference to a related type NAME.") - -|# diff --git a/annotation-plist.lisp b/annotation-plist.lisp deleted file mode 100644 index 4ce2d67..0000000 --- a/annotation-plist.lisp +++ /dev/null @@ -1,109 +0,0 @@ -;;; -*- lisp -*- - -;;;; This software was originally part of the SBCL software system. -;;;; SBCL is in the public domain and is provided with absolutely no warranty. -;;;; See the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte , mangled -;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others. - -(in-package :parse-docstrings) - - -;;;; Fetching annotations that were stored using ANNOTATION-DOCUMENTATION: - -(defun raw-annotations (name doc-type) - (let ((key :documentation-annotations)) - (when (and (consp name) (eq (car name) 'setf)) - (setf name (second name)) - (setf key :setf-documentation-annotations)) - (getf (get name key) doc-type))) - -(defun destructure-raw-annotation (x) - (let* ((kind (car x)) - (sym nil) - (docstring - (with-output-to-string (s) - (dolist (y (cdr x)) - (etypecase y - (string - (fresh-line s) - (write-string y s)) - (symbol - (setf sym y)) - (t - (warn "ignoring unrecognized sub-annotation: ~A" y))))))) - (values kind sym docstring))) - -(defun parse-raw-annotations (annotations) - (let ((d-a (make-instance 'documentation-annotations))) - (with-slots (arguments - return-values - conditions - slot-accessors - constructors - see-also-list) - d-a - (let ((docstring - (with-output-to-string (s) - (dolist (x annotations) - (typecase x - (string - (fresh-line s) - (write-string x s)) - (list - (multiple-value-bind (kind sym docstring) - (destructure-raw-annotation x) - (ecase kind - (:argument - (push (make-instance 'parameter-like-annotation - :name sym - :docstring docstring) - arguments)) - (:return-value - (push (make-instance 'parameter-like-annotation - :name sym - :docstring docstring) - return-values)) - (:condition - (push (make-instance 'cross-reference-annotation - :target sym - :doc-type 'type) - conditions)) - (:slot-accessor - (push (make-instance 'cross-reference-annotation - :target sym - :doc-type 'function) - slot-accessors)) - (:constructor - (push (make-instance 'cross-reference-annotation - :target sym - :doc-type 'function) - constructors)) - (:see-also-function - (push (make-instance 'cross-reference-annotation - :target sym - :doc-type 'function) - see-also-list)) - (:see-also-variable - (push (make-instance 'cross-reference-annotation - :target sym - :doc-type 'variable) - see-also-list)) - (:see-also-type - (push (make-instance 'cross-reference-annotation - :target sym - :doc-type 'type) - see-also-list))))) - (t - (warn "ignoring unrecognized annotation: ~A" x))))))) - (setf arguments (nreverse arguments)) - (setf return-values (nreverse return-values)) - (setf conditions (nreverse conditions)) - (setf slot-accessors (nreverse slot-accessors)) - (setf constructors (nreverse constructors)) - (setf see-also-list (nreverse see-also-list)) - (values docstring d-a))))) - -(defun annotations (name doc-type) - (parse-raw-annotations (raw-annotations name doc-type))) diff --git a/classes.lisp b/classes.lisp deleted file mode 100644 index b75a7c3..0000000 --- a/classes.lisp +++ /dev/null @@ -1,202 +0,0 @@ -;;; -*- lisp -*- - -;;;; This software was originally part of the SBCL software system. -;;;; SBCL is in the public domain and is provided with absolutely no warranty. -;;;; See the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte , mangled -;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others. - -;;;; TODO -;;;; * This is getting complicated enough that tests would be good - -#+sbcl ;; FIXME: should handle this in the .asd file -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'sb-introspect)) - -(in-package #:parse-docstrings) - - -;;; The DOCUMENTATION* class - -(defclass documentation* () - ((name :initarg :name :reader get-name) - (kind :initarg :kind :reader get-kind) - (content :accessor get-content) - (children :initarg :children :initform nil :reader get-children) - (package :initform *documentation-package* :reader get-package) - (package-name :initform *documentation-package-name* - :reader get-package-name))) - - -;;;; Markup classes - -(defclass document-block () ()) - -(defclass lisp-block (document-block) - ((string :initarg :string :reader get-string))) - -(defclass itemization (document-block) - ((items :initarg :items :reader get-items))) - -(defclass section (document-block) - ((blocks :initarg :blocks :reader get-blocks))) - -(defmethod print-object ((section section) stream) - (print-unreadable-object (section stream :type t) - (prin1 (get-blocks section) stream))) - -(defclass paragraph (document-block) - ((string :initarg :string :reader get-string))) - -(defmethod print-object ((paragraph paragraph) stream) - (print-unreadable-object (paragraph stream :type t) - (prin1 (get-string paragraph) stream))) - -(defclass tabulation (document-block) - ((items :initarg :items :reader get-items))) - -(defclass tabulation-item (document-block) - ((title :initarg :title :reader get-title) - (body :initarg :body :reader get-body))) - - -;;;; Annotation Classes - -(defclass documentation-annotations () - ((arguments :initform nil - :accessor argument-annotations) - (return-values :initform nil - :accessor return-value-annotations) - (conditions :initform nil - :accessor condition-annotations) - (slot-accessors :initform nil - :accessor slot-accessor-annotations) - (constructors :initform nil - :accessor constructor-annotation) - (see-also-list :initform nil - :accessor see-also-annotations)) - (:documentation - "This class stores annotations for docstrings, specifing for additional - information on arguments, return values, and cross references. - - Depending on the docstring syntax in use, annotation can be specified - directly in the docstring using special markup. - - Alternatively, the plist of symbol that names a definition can be used - to store annotations separately from the docstring. Refer to the - ANNOTATE-DOCUMENTATION macro for details.")) - -(annotate-documentation (documentation-annotations type) - (:slot-accessor argument-annotations) - (:slot-accessor return-value-annotations) - (:slot-accessor condition-annotations) - (:slot-accessor slot-accessor-annotations) - (:slot-accessor constructor-annotation) - (:slot-accessor see-also-annotations) - (:constructor annotations)) - -(annotate-documentation (argument-annotations function) - (:argument object "An instance of DOCUMENTATION-ANNOTATIONS") - (:return-value "A list of PARAMETER-LIKE-ANNOTATION objects") - "Returns annotations for this function's arguments. - - Each annotation records the name of the argument, and a docstring - describing details of the argument, e.g. its type. - - It is recommended (but currently not required) that arguments - in list correspond to the original names in the lambda list, and that - their order is preserved.") - -(annotate-documentation (return-value-annotations function) - (:argument object "An instance of DOCUMENTATION-ANNOTATIONS") - (:return-value "A list of PARAMETER-LIKE-ANNOTATION objects") - "Returns annotations for this function's return values. - - Each annotation records a docstring describing details of return value, - e.g. its type. Additionally, a name can be specified for annotation, - allowing HyperSpec-like descriptions of each return value. - - Only functions using multiple values will have more than one annotation - in this slot. - - Where multiple values are used, annotations in this list are stored in the - order of their return values.") - -(annotate-documentation (condition-annotations function) - (:argument object "An instance of DOCUMENTATION-ANNOTATIONS") - (:return-value "A list of CROSS-REFERENCE-ANNOTATION objects") - "Returns annotations for condition classes signalled by this function. - - Each entry is this list is a cross reference for a type, referring to - a condition class that might be signalled. - - Entries in this list can occur in any order.") - -(annotate-documentation (constructor-annotations function) - (:argument object "An instance of DOCUMENTATION-ANNOTATIONS") - (:return-value "A list of CROSS-REFERENCE-ANNOTATION objects") - "Returns annotations for functions serving as constructors for this type. - - In this documentation, constructor for a type is any function that - returns fresh instances of that type. - - This kind of annotation is useful when a type FOO is usually created - through a wrapper function MAKE-FOO rather than direct calls to - MAKE-INSTANCE. - - Entries in this list can occur in any order.") - -(annotate-documentation (slot-accessor-annotations function) - (:argument object "An instance of DOCUMENTATION-ANNOTATIONS") - (:return-value "A list of CROSS-REFERENCE-ANNOTATION objects") - "Returns annotations for functions serving as slot readers or accessors. - - Annotations in this list document that this class has a slot accessible - through the function designated by the cross reference, and possibly - settable through a setf function for the same name. - - This kind of annotation is most useful for programs that opt not to - document slots directly, and prefer to document the slot accessors as - ordinary functions instead. - - Entries in this list can occur in any order.") - -(annotate-documentation (see-also-annotations function) - (:argument object "An instance of DOCUMENTATION-ANNOTATIONS") - (:return-value "A list of CROSS-REFERENCE-ANNOTATION objects") - "Returns annotations for related definitions. - - Cross-reference annotations in this list are meant to augment the - CONDITION-ANNOTATIONS, CONSTRUCTOR-ANNOTATIONS, and - SLOT-ACCESSOR-ANNOTATIONS. Any cross reference can be added to this list, - assuming that the target of the cross reference is related to the current - function, and that relation is not made explict in the docstring. - - Entries in this list can occur in any order.") - -(defclass annotation () - ()) - -(defclass cross-reference-annotation (annotation) - ((target :initarg :target - :accessor cross-reference-target) - (doc-type :initarg :doc-type - :accessor cross-reference-doc-type))) - -(defun make-cross-reference-annotation (target doc-type) - (make-instance 'cross-reference-annotation - :target target - :doc-type doc-type)) - -(defclass parameter-like-annotation (annotation) - ((name :initarg :name - :accessor annotation-name) - (docstring :initarg :docstring :accessor annotated-docstring))) - -(defun make-parameter-like-annotation (name docstring) - (make-instance 'parameter-like-annotation - :name name - :docstring docstring)) - - diff --git a/package.lisp b/package.lisp dissimilarity index 74% index 4a1970a..90225b9 100644 --- a/package.lisp +++ b/package.lisp @@ -1,41 +1,5 @@ -(defpackage #:parse-docstrings - (:use #:cl #-sbcl #:c2mop #+sbcl #:sb-mop) - (:export #:documentation* - #:collect-documentation - - #:collect-symbol-documentation - - #:get-name - #:get-kind - #:get-content - #:get-items - #:get-blocks - #:get-string - #:get-title - #:get-package-name - #:get-body - #:get-children - - #:document-block - #:itemization - #:section - #:paragraph - #:tabulation - #:tabulation-item - #:lisp-content - #:lisp-block - - #:documentation< - #:setf-name-p - - #:lambda-list)) - -(defpackage #:parse-docstrings.sbcl - (:use :cl) - (:export #:parse-docstring)) - -(defpackage #:texinfo-docstrings - (:use #:cl #-sbcl #:c2mop #+sbcl #:sb-mop) - (:export #:generate-includes #:document-package) - (:documentation - "Tools to generate TexInfo documentation from docstrings.")) +(defpackage #:texinfo-docstrings + (:use #:cl #-sbcl #:c2mop #+sbcl #:sb-mop) + (:export #:generate-includes #:document-package) + (:documentation + "Tools to generate TexInfo documentation from docstrings.")) diff --git a/parse-docstrings.lisp b/parse-docstrings.lisp deleted file mode 100644 index 71ad5a8..0000000 --- a/parse-docstrings.lisp +++ /dev/null @@ -1,307 +0,0 @@ -;;; -*- lisp -*- - -;;;; This software was originally part of the SBCL software system. -;;;; SBCL is in the public domain and is provided with absolutely no warranty. -;;;; See the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte , mangled -;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others. - -;;;; TODO -;;;; * This is getting complicated enough that tests would be good - -#+sbcl ;; FIXME: should handle this in the .asd file -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'sb-introspect)) - -(in-package #:parse-docstrings) - -(defun function-arglist (function) - #+sbcl (sb-introspect:function-arglist function) - #-sbcl (error "function-arglist unimplemented")) - -;;;; various specials and parameters - -(defvar *documentation-package*) -(defvar *documentation-package-name*) - -(defparameter *documentation-types* - '(function - method-combination - setf - ;;structure ; also handled by `type' - type - variable) - "A list of symbols accepted as second argument of `documentation'") - -(defparameter *ordered-documentation-kinds* - '(package type structure condition class macro)) - -;;;; utilities - -(defun flatten (list) - (cond ((null list) - nil) - ((consp (car list)) - (nconc (flatten (car list)) (flatten (cdr list)))) - ((null (cdr list)) - (cons (car list) nil)) - (t - (cons (car list) (flatten (cdr list)))))) - -(defun flatten-to-string (list) - (format nil "~{~A~^~%~}" (flatten list))) - -(defun setf-name-p (name) - (or (symbolp name) - (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) - -(defgeneric specializer-name (specializer)) - -(defmethod specializer-name ((specializer eql-specializer)) - (list 'eql (eql-specializer-object specializer))) - -(defmethod specializer-name ((specializer class)) - (class-name specializer)) - -(defun specialized-lambda-list (method) - ;; courtecy of AMOP p. 61 - (let* ((specializers (method-specializers method)) - (lambda-list (method-lambda-list method)) - (n-required (length specializers))) - (append (mapcar (lambda (arg specializer) - (if (eq specializer (find-class 't)) - arg - `(,arg ,(specializer-name specializer)))) - (subseq lambda-list 0 n-required) - specializers) - (subseq lambda-list n-required)))) - -(defun docstring (x doc-type) - (handler-bind ((warning #'muffle-warning)) - (cl:documentation x doc-type))) - - - -;;;; generating various names - -(defgeneric name (thing) - (:documentation "Name for a documented thing. Names are either -symbols or lists of symbols.")) - -(defmethod name ((symbol symbol)) - symbol) - -(defmethod name ((cons cons)) - cons) - -(defmethod name ((package package)) - (package-name package)) - -(defmethod name ((method method)) - (list - (generic-function-name (method-generic-function method)) - (method-qualifiers method) - (specialized-lambda-list method))) - - -;;;; frontend selection - -(defvar *default-docstring-parser* - 'parse-docstrings.sbcl:parse-docstring) - -(defgeneric docstring-parser-for (x)) - -(defmethod docstring-parser-for ((x package)) - (let ((configuration - (find-symbol "DOCSTRING-PARSER" x))) - (or (and configuration - (funcall configuration)) - *default-docstring-parser*))) - -(defmethod docstring-parser-for ((x symbol)) - (docstring-parser-for (symbol-package x))) - - -;;;; methods related to the documentation* class - -(defun get-symbol (doc) - (let ((name (get-name doc))) - (cond ((symbolp name) - name) - ((and (consp name) (eq 'setf (car name))) - (second name)) - (t - (error "Don't know which symbol to sort by: ~S" name))))) - -(defmethod print-object ((documentation documentation*) stream) - (print-unreadable-object (documentation stream :type t) - (princ (list (get-kind documentation) (get-name documentation)) stream))) - -(defgeneric make-documentation (x doc-type string)) - -(defmethod make-documentation :around (x doc-type string) - (let ((doc (call-next-method))) - (setf (get-content doc) - (funcall (docstring-parser-for (if (packagep x) x (name x))) string)) - doc)) - -(defmethod make-documentation ((x package) doc-type string) - (declare (ignore doc-type string)) - (make-instance 'documentation* - :name (name x) - :kind 'package)) - -(defmethod make-documentation (x (doc-type (eql 'function)) string) - (declare (ignore doc-type string)) - (let* ((fdef (and (fboundp x) (fdefinition x))) - (name x) - (kind (cond ((and (symbolp x) (special-operator-p x)) - 'special-operator) - ((and (symbolp x) (macro-function x)) - 'macro) - ((typep fdef 'generic-function) - (assert (or (symbolp name) (setf-name-p name))) - 'generic-function) - (fdef - (assert (or (symbolp name) (setf-name-p name))) - 'function))) - (children (when (eq kind 'generic-function) - (collect-gf-documentation fdef)))) - (make-instance 'documentation* - :name (name x) - :kind kind - :children children))) - -(defmethod make-documentation ((x method) doc-type string) - (declare (ignore doc-type string)) - (make-instance 'documentation* - :name (name x) - :kind 'method)) - -(defmethod make-documentation (x (doc-type (eql 'type)) string) - (declare (ignore string)) - (make-instance 'documentation* - :name (name x) - :kind (etypecase (find-class x nil) - (structure-class 'structure) - (standard-class 'class) - (sb-pcl::condition-class 'condition) - ((or built-in-class null) 'type)))) - -(defmethod make-documentation (x (doc-type (eql 'variable)) string) - (declare (ignore string)) - (make-instance 'documentation* - :name (name x) - :kind (if (constantp x) - 'constant - 'variable))) - -(defmethod make-documentation (x (doc-type (eql 'setf)) string) - (declare (ignore doc-type string)) - (make-instance 'documentation* - :name (name x) - :kind 'setf-expander)) - -(defmethod make-documentation (x doc-type string) - (declare (ignore string)) - (make-instance 'documentation* - :name (name x) - :kind doc-type)) - -(defun documentation* (x doc-type) - "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if -there is no corresponding docstring." - (let ((docstring (docstring x doc-type))) - (when (plusp (length docstring)) - (make-documentation x doc-type docstring)))) - -(defun lambda-list (doc) - ;; KLUDGE: Eugh. - ;; - ;; believe it or not, the above comment was written before CSR came along - ;; and obfuscated this. (2005-07-04) - (labels ((clean (x &key optional key) - (typecase x - (atom x) - ((cons (member &optional)) - (cons (car x) (clean (cdr x) :optional t))) - ((cons (member &key)) - (cons (car x) (clean (cdr x) :key t))) - ;; &ENVIRONMENT ENV and &WHOLE FORM is not interesting to the user. - ((cons (member &environment &whole)) - (clean (cddr x) :optional optional :key key)) - ((cons cons) - (cons - (cond (key (if (consp (caar x)) - (caaar x) - (caar x))) - (optional (caar x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional))) - (cons - (cons - (cond ((or key optional) (car x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional)))))) - (case (get-kind doc) - ((package constant variable structure class condition nil) - nil) -;;; ((type) -;;; ;; FIND-SYMBOL to avoid compilation errors on older SBCL versions: -;;; (clean (funcall (find-symbol "INFO" :sb-int) -;;; :type -;;; :lambda-list -;;; (get-name doc)))) - (method - (third (get-name doc))) - (t - (when (symbolp (get-name doc)) - (clean (function-arglist (get-name doc)))))))) - -(defun documentation< (x y) - (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) - (p2 (position (get-kind y) *ordered-documentation-kinds*))) - (cond ((and p1 p2 (/= p1 p2)) - (< p1 p2)) - ((and (or p1 p2) (not (and p1 p2))) - (and p1 t)) - (t - (string< (string (get-symbol x)) (string (get-symbol y))))))) - -;;;; main logic - -(defun collect-gf-documentation (gf) - "Collects method documentation for the generic function GF" - (loop for method in (generic-function-methods gf) - for doc = (documentation* method t) - when doc - collect doc)) - -(defun collect-name-documentation (name) - (loop for type in *documentation-types* - for doc = (documentation* name type) - when doc - collect doc)) - -(defun collect-symbol-documentation (symbol) - "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of -the form DOC instances. See `*documentation-types*' for the possible -values of doc-type." - (nconc (collect-name-documentation symbol) - (collect-name-documentation (list 'setf symbol)))) - -(defun collect-documentation (package &optional package-name) - "Collects all documentation for all external symbols of the given -package, as well as for the package itself." - (let* ((*documentation-package* (find-package package)) - (*documentation-package-name* - (or package-name (package-name *documentation-package*))) - (docs nil)) - (check-type package package) - (do-external-symbols (symbol package) - (setf docs (nconc (collect-symbol-documentation symbol) docs))) - (let ((doc (documentation* *documentation-package* t))) - (when doc - (push doc docs))) - docs)) diff --git a/syntax-sbcl.lisp b/syntax-sbcl.lisp deleted file mode 100644 index dc7b7ba..0000000 --- a/syntax-sbcl.lisp +++ /dev/null @@ -1,397 +0,0 @@ -;;; -*- lisp -*- - -;;;; A docstring parser implementing syntax used for the sbcl manual. - -;;;; This software was originally part of the SBCL software system. -;;;; SBCL is in the public domain and is provided with absolutely no warranty. -;;;; See the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte , mangled -;;;; by Nikodemus Siivola, Luis Oliveira, David Lichteblau, and others. - -;;;; TODO -;;;; * Verbatim text -;;;; * Quotations -;;;; * This is getting complicated enough that tests would be good -;;;; * Nesting (currently only nested itemizations work) - -;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): -;;;; -;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in -;;;; the argument list of the defun / defmacro. -;;;; -;;;; Lines starting with * or - that are followed by intented lines -;;;; are marked up with @itemize. -;;;; -;;;; Lines containing only a SYMBOL that are followed by indented -;;;; lines are marked up as @table @code, with the SYMBOL as the item. - -(in-package #:parse-docstrings.sbcl) - - -;;;; utilities - -(defun string-lines (string) - "Lines in STRING as a vector." - (coerce (with-input-from-string (s string) - (loop for line = (read-line s nil nil) - while line collect line)) - 'vector)) - -(defun whitespacep (char) - (find char #(#\tab #\space #\page))) - -(defun indentation (line) - "Position of first non-SPACE character in LINE." - (position-if-not (lambda (c) (char= c #\Space)) line)) - -(defun flatten (list) - (cond ((null list) - nil) - ((consp (car list)) - (nconc (flatten (car list)) (flatten (cdr list)))) - ((null (cdr list)) - (cons (car list) nil)) - (t - (cons (car list) (flatten (cdr list)))))) - -(defun flatten-to-string (list) - (format nil "~{~A~^~%~}" (flatten list))) - - -;;; line markups - -(defparameter *itemize-start-characters* '(#\* #\-) - "Characters that might start an itemization in docstrings when - at the start of a line.") - -(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&" - "List of characters that make up symbols in a docstring.") - -(defparameter *symbol-delimiters* " ,.!?; -") - -(defun locate-symbols (line) - "Return a list of index pairs of symbol-like parts of LINE." - ;; This would be a good application for a regex ... - (do ((result nil) - (begin nil) - (maybe-begin t) - (i 0 (1+ i))) - ((= i (length line)) - ;; symbol at end of line - (when (and begin (or (> i (1+ begin)) - (not (member (char line begin) '(#\A #\I))))) - (push (list begin i) result)) - (nreverse result)) - (cond - ((and begin (find (char line i) *symbol-delimiters*)) - ;; symbol end; remember it if it's not "A" or "I" - (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) - (push (list begin i) result)) - (setf begin nil - maybe-begin t)) - ((and begin (not (find (char line i) *symbol-characters*))) - ;; Not a symbol: abort - (setf begin nil)) - ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) - ;; potential symbol begin at this position - (setf begin i - maybe-begin nil)) - ((find (char line i) *symbol-delimiters*) - ;; potential symbol begin after this position - (setf maybe-begin t)) - (t - ;; Not reading a symbol, not at potential start of symbol - (setf maybe-begin nil))))) - -;;; lisp sections - -(defun lisp-section-p (line line-number lines) - "Returns T if the given LINE looks like start of lisp code -- -ie. if it starts with whitespace followed by a paren or -semicolon, and the previous line is empty" - (let ((offset (indentation line))) - (and offset - (plusp offset) - (find (find-if-not #'whitespacep line) "(;") - (empty-p (1- line-number) lines)))) - -(defun collect-lisp-section (lines line-number) - (let ((lisp (loop for index = line-number then (1+ index) - for line = (and (< index (length lines)) - (svref lines index)) - while (indentation line) - collect line))) - (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) - -;;; itemized sections - -(defun maybe-itemize-offset (line) - "Return NIL or the indentation offset if LINE looks like it starts -an item in an itemization." - (let* ((offset (indentation line)) - (char (when offset (char line offset)))) - (and offset - (member char *itemize-start-characters* :test #'char=) - (char= #\Space (find-if-not (lambda (c) (char= c char)) - line :start offset)) - offset))) - -(defun collect-maybe-itemized-section (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) - (result nil) - (lines-consumed 0)) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-itemize-offset line) - do (cond - ((not indentation) - ;; empty line -- inserts paragraph. - (push "" result) - (incf lines-consumed)) - ((and offset (> indentation this-offset)) - ;; nested itemization -- handle recursively - ;; FIXME: tabulations in itemizations go wrong - (multiple-value-bind (sub-lines-consumed sub-itemization) - (collect-maybe-itemized-section lines line-number) - (when sub-lines-consumed - (incf line-number (1- sub-lines-consumed)) ; +1 on next loop - (incf lines-consumed sub-lines-consumed) - (setf result (nconc (nreverse sub-itemization) result))))) - ((and offset (= indentation this-offset)) - ;; start of new item - (push (format nil "@item ~A" - (texinfo-line (subseq line (1+ offset)))) - result) - (incf lines-consumed)) - ((and (not offset) (> indentation this-offset)) - ;; continued item from previous line - (push (texinfo-line line) result) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - ;; a single-line itemization isn't. - (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) - nil))) - -;;; tabulation sections - -(defun tabulation-body-p (offset line-number lines) - (when (< -1 line-number (length lines)) - (let ((offset2 (indentation (svref lines line-number)))) - (and offset2 (< offset offset2))))) - -(defun tabulation-p (offset line-number lines direction) - (let ((step (ecase direction - (:backwards (1- line-number)) - (:forwards (1+ line-number))))) - (when (and (plusp line-number) (< line-number (length lines))) - (and (eql offset (indentation (svref lines line-number))) - (or (when (eq direction :backwards) - (empty-p step lines)) - (tabulation-p offset step lines direction) - (tabulation-body-p offset step lines)))))) - -(defun empty-p (line-number lines) - (or (eql -1 line-number) - (and (< line-number (length lines)) - (not (indentation (svref lines line-number)))))) - -(defun maybe-tabulation-offset (line-number lines) - "Return NIL or the indentation offset if LINE looks like it starts -an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an -empty line, another tabulation label, or a tabulation body, (3) and -followed another tabulation label or a tabulation body." - (let* ((line (svref lines line-number)) - (offset (indentation line)) - (prev (1- line-number)) - (next (1+ line-number))) - (when (and offset (plusp offset)) - (and (or (empty-p prev lines) - (tabulation-body-p offset prev lines) - (tabulation-p offset prev lines :backwards)) - (or (tabulation-body-p offset next lines) - (tabulation-p offset next lines :forwards)) - offset)))) - -;;; section markup - -(defmacro with-maybe-section (index &rest forms) - `(multiple-value-bind (count collected) (progn ,@forms) - (when count - (dolist (line collected) - (write-line line *document-output*)) - (incf ,index (1- count))))) - -(defmacro maybe-section (index &body forms) - `(multiple-value-bind (count section) (progn ,@forms) - (when count - (push section parsed) - (incf ,index (1- count))))) - -(defun parse-docstring (docstring) - (let ((lines (string-lines docstring)) - (parsed nil) - (current nil)) - (labels ((end-paragraph () - (when current - (push (make-instance 'parse-docstrings:paragraph - :string (flatten-to-string (reverse current))) - parsed) - (setf current nil))) - (add-line (line) - (let ((trimmed (string-trim '(#\space #\tab) line))) - (if (plusp (length trimmed)) - (push trimmed current) - (end-paragraph))))) - (loop for line-number from 0 below (length lines) - for line = (svref lines line-number) - do (cond - ((maybe-section line-number - (and (lisp-section-p line line-number lines) - (parse-lisp-block lines line-number)))) - ((maybe-section line-number - (and (maybe-itemize-offset line) - (parse-maybe-itemization lines line-number)))) - ((maybe-section line-number - (and (maybe-tabulation-offset line-number lines) - (parse-maybe-tabulation lines line-number)))) - (t - (add-line line)))) - (end-paragraph) - (if parsed - (section (reverse parsed)) - (error "empty parse? ~S" docstring))))) - -(defun parse-lisp-block (lines line-number) - (let ((lisp (loop for index = line-number then (1+ index) - for line = (and (< index (length lines)) (svref lines index)) - while (indentation line) - collect line))) - (values (length lisp) (make-instance 'parse-docstrings:lisp-block - :string (flatten-to-string lisp))))) - -(defun section (paragraphs) - (if (cdr paragraphs) - (make-instance 'parse-docstrings:section :blocks paragraphs) - (car paragraphs))) - -(defun parse-maybe-itemization (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) - (items nil) - (paragraphs nil) - (current nil) - (lines-consumed 0)) - (labels ((end-paragraph () - (when current - (push (make-instance 'parse-docstrings:paragraph - :string (flatten-to-string (reverse current))) - paragraphs) - (setf current nil))) - (end-item () - (end-paragraph) - (when paragraphs - (push (section (reverse paragraphs)) items) - (setf paragraphs nil))) - (add-line (line) - (push (string-trim '(#\space #\tab) line) current))) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-itemize-offset line) - do (cond - ((not indentation) - ;; empty line, a paragraph break - (end-paragraph) - (incf lines-consumed)) - ((and offset (> indentation this-offset)) - (end-item) - ;; nested itemization -- handle recursively FIXME: - ;; tabulations in itemizations go wrong - (multiple-value-bind (sub-lines-consumed sublist) - (parse-maybe-itemization lines line-number) - (when sub-lines-consumed - (incf line-number (1- sub-lines-consumed)) ; +1 on next loop - (incf lines-consumed sub-lines-consumed) - (push sublist items)))) - ((and offset (= indentation this-offset)) - ;; start of new item - (end-item) - (add-line (subseq line (1+ offset))) - (incf lines-consumed)) - ((and (not offset) (> indentation this-offset)) - ;; continued paragraph from previous line - (add-line line) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - (end-item)) - ;; a single-item itemization isn't. - (if (> (length items) 1) - (values lines-consumed (make-instance 'parse-docstrings:itemization - :items (nreverse items))) - (values nil nil)))) - - -(defun parse-maybe-tabulation (lines starting-line) - ;; Return index of next line to be processed outside - (let ((this-offset (maybe-tabulation-offset starting-line lines)) - (items nil) - (paragraphs nil) - (title nil) - (current nil) - (lines-consumed 0)) - (labels ((end-paragraph () - (when current - (push (make-instance 'parse-docstrings:paragraph - :string (flatten-to-string (reverse current))) - paragraphs) - (setf current nil))) - (end-item () - (end-paragraph) - (when paragraphs - (push (make-instance 'parse-docstrings:tabulation-item - :title title - :body (section (reverse paragraphs))) - items) - (setf paragraphs nil - title nil))) - (set-title (line) - (setf title (string-trim '(#\space #\tab) line))) - (add-line (line) - (push (string-trim '(#\space #\tab) line) current))) - (assert this-offset) - (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-tabulation-offset line-number lines) - do (cond - ((not indentation) - (end-paragraph) - (incf lines-consumed)) - ((and offset (= indentation this-offset)) - ;; start of new item, or continuation of previous item - (cond ((and title (not (maybe-tabulation-offset line-number lines))) - (add-line line)) - (t - (end-item) - (set-title line))) - (incf lines-consumed)) - ((> indentation this-offset) - ;; continued item from previous line - (add-line line) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) - (end-item)) - (values lines-consumed - (make-instance 'parse-docstrings:tabulation - :items (reverse items))))) diff --git a/texinfo-docstrings.asd b/texinfo-docstrings.asd index 087d295..5cfb4f9 100644 --- a/texinfo-docstrings.asd +++ b/texinfo-docstrings.asd @@ -1,14 +1,9 @@ ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- (asdf:defsystem texinfo-docstrings - :depends-on (#-sbcl closer-mop) + :depends-on (:parse-docstrings #-sbcl :closer-mop) :serial t :components ((:file "package") - (:file "annotate-documentation") - (:file "classes") - (:file "annotation-plist") - (:file "parse-docstrings") - (:file "syntax-sbcl") (:file "writer-common") (:file "writer-html") (:file "writer-texinfo"))) -- 2.11.4.GIT