master: Make DOCUMENTATION strip markup from SBCL definitions
melisgl via Sbcl-commits <[email protected]> Tue, 30 Jun 2026 15:08:09 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 27621b01ca39e50930f68d29c6966400f4274103 (commit)
from 3335c2b15090630b19eb0aaaf5596361182b5a09 (commit)
- Log -----------------------------------------------------------------
commit 27621b01ca39e50930f68d29c6966400f4274103
Author: Gabor Melis <[email protected]>
Date: Tue Jun 30 14:13:06 2026 +0200
Make DOCUMENTATION strip markup from SBCL definitions
... and normalize the indentation of their docstrings, too.
Doing this lazily in DOCUMENTATION allows interactive work on
docstrings (e.g. change a docstring, recompile its definition,
generate documentation from the image). I don't think the overhead in
DOCUMENTATION is a factor.
---
contrib/sb-manual/docstring.lisp | 53 ---------
contrib/sb-manual/markdown.lisp | 17 ---
contrib/sb-manual/package.lisp | 5 +-
contrib/sb-manual/texinfo.lisp | 45 +++----
src/pcl/documentation.lisp | 247 ++++++++++++++++++++++++++++++++++++++-
5 files changed, 273 insertions(+), 94 deletions(-)
diff --git a/contrib/sb-manual/docstring.lisp b/contrib/sb-manual/docstring.lisp
index 455a38b53..3dc8e13c1 100644
--- a/contrib/sb-manual/docstring.lisp
+++ b/contrib/sb-manual/docstring.lisp
@@ -1,58 +1,5 @@
(in-package :sb-manual)
-;;; Before processing Markdown, the docstring indentation is
-;;; normalized by stripping the longest run of leading spaces common
-;;; to all non-blank lines except the first. This is compatible with
-;;; PAX (see PAX::@MARKDOWN-SUPPORT).
-(defun reindent-docstring (docstring)
- (let ((indentation (docstring-indentation docstring)))
- (strip-docstring-indent docstring indentation t)))
-
-
-;;;; Utilities lifted from DRef and MGL-PAX
-
-;;; Return the minimum number of leading spaces in non-blank lines
-;;; after the first.
-(defun docstring-indentation (docstring &key (first-line-special-p t))
- (let ((n-min-indentation nil))
- (with-input-from-string (s docstring)
- (loop for i upfrom 0
- for line = (read-line s nil nil)
- while line
- do (when (and (or (not first-line-special-p) (plusp i))
- (not (blankp line)))
- (when (or (null n-min-indentation)
- (< (n-leading-spaces line) n-min-indentation))
- (setq n-min-indentation (n-leading-spaces line))))))
- (or n-min-indentation 0)))
-
-(defun n-leading-spaces (line)
- (let ((n 0))
- (loop for i below (length line)
- while (char= (aref line i) #\Space)
- do (incf n))
- n))
-
-(defun subseq* (seq start)
- (subseq seq (min (length seq) start)))
-
-(defun strip-docstring-indent (docstring indentation first-line-special-p)
- (with-output-to-string (out)
- (with-input-from-string (s docstring)
- (loop for i upfrom 0
- do (multiple-value-bind (line missing-newline-p)
- (read-line s nil nil)
- (unless line
- (return))
- (write-string (if (and first-line-special-p
- (zerop i))
- line
- (subseq* line indentation))
- out)
- (unless missing-newline-p
- (terpri out)))))))
-
-
;;;; Determining the package for parsing docstrings
;;;;
;;;; The package for parsing is the package that was in effect when
diff --git a/contrib/sb-manual/markdown.lisp b/contrib/sb-manual/markdown.lisp
index 9e8505fe2..0ca17991e 100644
--- a/contrib/sb-manual/markdown.lisp
+++ b/contrib/sb-manual/markdown.lisp
@@ -194,23 +194,6 @@
(t
(cons (car list) (flatten (cdr list))))))
-(defun whitespacep (char)
- (find char #(#\tab #\space #\page #\newline #\return)))
-
-;;; Split STRING into a vector of lines.
-(defun string-lines (string)
- (coerce (with-input-from-string (s string)
- (loop for line = (read-line s nil nil)
- while line collect line))
- 'vector))
-
-;;; Position of the first non-SPACE character in LINE.
-(defun indentation (line)
- (position-if-not (lambda (c) (char= c #\Space)) line))
-
-(defun blankp (line)
- (null (indentation line)))
-
(defun flatten-to-string (list)
(format nil "~{~A~^-~}" (flatten list)))
diff --git a/contrib/sb-manual/package.lisp b/contrib/sb-manual/package.lisp
index 02a7fadc0..25558e083 100644
--- a/contrib/sb-manual/package.lisp
+++ b/contrib/sb-manual/package.lisp
@@ -2,4 +2,7 @@
(handler-bind ((sb-int:package-at-variance #'muffle-warning))
(defpackage :sb-manual
(:use :cl :sb-alien)
- (:export #:use-pax))))
+ (:export #:use-pax)
+ (:import-from #:sb-pcl
+ #:string-lines #:whitespacep #:indentation #:blankp
+ #:reindent-docstring))))
diff --git a/contrib/sb-manual/texinfo.lisp b/contrib/sb-manual/texinfo.lisp
index ba101c61e..7babc46f0 100644
--- a/contrib/sb-manual/texinfo.lisp
+++ b/contrib/sb-manual/texinfo.lisp
@@ -10,28 +10,29 @@
(lambda-list* name locative-type)))
(defun %docstring (xref)
- (values (let ((name (xref-name xref))
- (locative-type (xref-locative-type xref)))
- (case locative-type
- ((function variable declaration)
- (documentation name locative-type))
- ((generic-function)
- (documentation name 'function))
- ((type class structure condition)
- (documentation name 'type))
- (t
- (cond ((eq locative-type (dummy 'macro))
- (documentation (macro-function name) t))
- ((eq locative-type (dummy 'setf-function))
- (documentation (fdefinition name) t))
- ((eq locative-type (dummy 'setf-generic-function))
- (documentation (fdefinition name) t))
- (t
- (assert nil () "Unexpected locative type in ~S."
- xref))))))
- ;; To be compatible with PAX::@PACKAGE-AND-READTABLE, we
- ;; always return a non-NIL package.
- (docstring-package xref)))
+ (let ((sb-pcl::*normalize-sbcl-docstrings* nil))
+ (values (let ((name (xref-name xref))
+ (locative-type (xref-locative-type xref)))
+ (case locative-type
+ ((function variable declaration)
+ (documentation name locative-type))
+ ((generic-function)
+ (documentation name 'function))
+ ((type class structure condition)
+ (documentation name 'type))
+ (t
+ (cond ((eq locative-type (dummy 'macro))
+ (documentation (macro-function name) t))
+ ((eq locative-type (dummy 'setf-function))
+ (documentation (fdefinition name) t))
+ ((eq locative-type (dummy 'setf-generic-function))
+ (documentation (fdefinition name) t))
+ (t
+ (assert nil () "Unexpected locative type in ~S."
+ xref))))))
+ ;; To be compatible with PAX::@PACKAGE-AND-READTABLE, we
+ ;; always return a non-NIL package.
+ (docstring-package xref))))
(defun lambda-list* (name kind)
(case kind
diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp
index 3bdebbcf1..15d9c9357 100644
--- a/src/pcl/documentation.lisp
+++ b/src/pcl/documentation.lisp
@@ -216,7 +216,45 @@
(t
x)))
(documentation (call-next-method)))
- (maybe-add-deprecation-note namespace name documentation)))
+ (maybe-add-deprecation-note namespace name
+ (normalize-sbcl-docstring x name doc-type
+ documentation))))
+
+(defvar *normalize-sbcl-docstrings* t)
+
+(defun normalize-sbcl-docstring (object name doc-type docstring)
+ (if (and *normalize-sbcl-docstrings*
+ docstring
+ (sbcl-definition-name-p object name doc-type))
+ (string-right-trim '(#\Newline) (markdown-to-plain-text
+ (reindent-docstring docstring)))
+ docstring))
+
+(defun non-setf-name (name)
+ (if (and (consp name)
+ (eq (first name) 'setf)
+ (consp (cdr name)))
+ (second name)
+ name))
+
+(defun sbcl-package-name-p (name)
+ (when (stringp name)
+ (or (string= name "COMMON-LISP")
+ (and (>= (length name) 3)
+ (string= name "SB-" :end1 3)))))
+
+(defun sbcl-definition-name-p (object name doc-type)
+ (and (member doc-type '(t compiler-macro function method-combination setf
+ structure type variable declaration))
+ (if (and (packagep object) (eq doc-type t))
+ (sbcl-package-name-p (package-name name))
+ (let ((name (non-setf-name name)))
+ (if (null name)
+ (null object)
+ (when (symbolp name)
+ (let ((package (symbol-package name)))
+ (when package
+ (sbcl-package-name-p (package-name package))))))))))
;;; functions, macros, and special forms
@@ -467,3 +505,210 @@ comparison.")
(dolist (args (prog1 *!docstrings* (makunbound '*!docstrings*)))
(apply #'(setf documentation) args))
+
+;;;; Markdown to plain text along the lines of SB-MANUAL::MARKDOWN-TO-TEXINFO
+
+(defun markdown-to-plain-text (string)
+ (markdown-lines-to-plain-text (string-lines string) 0))
+
+(defun markdown-lines-to-plain-text (lines base-indent)
+ (with-output-to-string (out)
+ (let ((buf nil))
+ (labels ((flush ()
+ (write-md-paragraph buf out)
+ (setq buf nil)))
+ (loop for l below (length lines)
+ for line = (svref lines l)
+ do (let ((n (write-md-block lines l base-indent out #'flush)))
+ (if n
+ (incf l (1- n))
+ (push line buf))))
+ (flush)))))
+
+(defun string-lines (string)
+ (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 #\Newline #\Return)))
+
+(defun indentation (line)
+ (position-if-not #'whitespacep line))
+
+(defun blankp (line)
+ (null (indentation line)))
+
+(defun write-md-paragraph (reversed-lines out)
+ (when reversed-lines
+ (let* ((str (format nil "~{~A~^~%~}" (reverse reversed-lines)))
+ (len (length str))
+ (bound t))
+ (loop for i below len
+ for c = (char str i)
+ do (cond
+ ((and bound (char= c #\\))
+ (when (and (< (1+ i) len)
+ (char= (char str (1+ i)) #\\))
+ (incf i))
+ (setf bound nil))
+ ((char= c #\`)
+ (incf i)
+ (loop repeat 2
+ while (< i len)
+ while (char= (char str i) #\\)
+ do (incf i))
+ (loop while (< i len)
+ while (char/= (char str i) #\`)
+ do (write-char (char str i) out)
+ (incf i))
+ (setq bound nil))
+ (t
+ (write-char c out)
+ (setq bound (whitespacep c)))))
+ (terpri out))))
+
+(defun write-md-block (lines index base-indent out flush-fn)
+ (or (write-md-fenced-code lines index base-indent out flush-fn)
+ (write-md-indented-code lines index base-indent out flush-fn)
+ (write-md-blockquote lines index base-indent out flush-fn)
+ (write-md-markdown-itemize lines index base-indent out flush-fn)))
+
+(defun write-md-fenced-code (lines start base-indent out flush-fn)
+ (declare (ignore base-indent))
+ (let* ((line (svref lines start))
+ (i (indentation line)))
+ (when (and i (>= (length line) (+ i 3))
+ (string= line "```" :start1 i :end1 (+ i 3)))
+ (funcall flush-fn)
+ (loop for l from (1+ start) below (length lines)
+ for line = (svref lines l)
+ for ind = (indentation line)
+ if (and ind (>= (length line) (+ ind 3))
+ (string= line "```" :start1 ind :end1 (+ ind 3)))
+ do (return (- (1+ l) start))
+ else do (write-line line out)
+ finally (return (- l start))))))
+
+(defun write-md-indented-code (lines start base-indent out flush-fn)
+ (when (or (zerop start)
+ (blankp (svref lines (1- start))))
+ (let ((i (indentation (svref lines start))))
+ (when (and i (>= i (+ base-indent 4)))
+ (funcall flush-fn)
+ (loop for l from start below (length lines)
+ for line = (svref lines l)
+ for ind = (indentation line)
+ while (or (null ind)
+ (>= ind (+ base-indent 4)))
+ do (write-line line out)
+ finally (return (- l start)))))))
+
+(defun write-md-blockquote (lines start base-indent out flush-fn)
+ (when (or (zerop start)
+ (blankp (svref lines (1- start))))
+ (let ((i (indentation (svref lines start))))
+ (when (and i (<= i (+ base-indent 3))
+ (char= (char (svref lines start) i) #\>))
+ (funcall flush-fn)
+ (let (stripped prefixes)
+ (loop for l from start below (length lines)
+ for line = (svref lines l)
+ for ind = (indentation line)
+ while (and ind (<= ind (+ base-indent 3))
+ (char= (char line ind) #\>))
+ do (let ((c-start (if (and (< (1+ ind) (length line))
+ (char= (char line (1+ ind)) #\Space))
+ (+ ind 2) (1+ ind))))
+ (push (subseq line c-start) stripped)
+ (push (subseq line 0 c-start) prefixes)))
+ (let ((inner (markdown-lines-to-plain-text
+ (coerce (nreverse stripped) 'vector) 0)))
+ (loop for prefix in (nreverse prefixes)
+ for line across (string-lines inner)
+ do (write-string prefix out)
+ (write-line line out)))
+ (length prefixes))))))
+
+(defun maybe-itemize-offset (line)
+ (let ((i (indentation line)))
+ (when (and i (< (1+ i) (length line))
+ (find (char line i) "-*")
+ (char= (char line (1+ i)) #\Space))
+ i)))
+
+(defun write-md-markdown-itemize (lines start base-indent out flush-fn)
+ (when (eql (maybe-itemize-offset (svref lines start)) base-indent)
+ (funcall flush-fn)
+ (let ((child (+ base-indent 4))
+ (buf nil))
+ (labels ((flush ()
+ (write-md-paragraph buf out)
+ (setq buf nil)))
+ (loop for l from start below (length lines)
+ for line = (svref lines l)
+ for ind = (indentation line)
+ do (cond ((blankp line)
+ (flush)
+ (write-line line out))
+ ((eql (maybe-itemize-offset line) base-indent)
+ (flush)
+ (push line buf))
+ ((>= ind child)
+ (let ((n (write-md-block lines l child out #'flush)))
+ (if n
+ (incf l (1- n))
+ (push line buf))))
+ ((> ind base-indent)
+ (push line buf))
+ (t
+ (loop-finish)))
+ finally (flush)
+ (return (- l start)))))))
+
+
+;;; Normalize docstring indentation by stripping the longest run of
+;;; leading spaces common to all non-blank lines except the first.
+(defun reindent-docstring (docstring)
+ (let ((indentation (docstring-indentation docstring)))
+ (strip-docstring-indent docstring indentation t)))
+
+;;; Return the minimum number of leading spaces in non-blank lines
+;;; after the first.
+(defun docstring-indentation (docstring &key (first-line-special-p t))
+ (let ((n-min-indentation nil))
+ (with-input-from-string (s docstring)
+ (loop for i upfrom 0
+ for line = (read-line s nil nil)
+ while line
+ do (when (and (or (not first-line-special-p) (plusp i))
+ (not (blankp line)))
+ (when (or (null n-min-indentation)
+ (< (n-leading-spaces line) n-min-indentation))
+ (setq n-min-indentation (n-leading-spaces line))))))
+ (or n-min-indentation 0)))
+
+(defun n-leading-spaces (line)
+ (let ((n 0))
+ (loop for i below (length line)
+ while (char= (aref line i) #\Space)
+ do (incf n))
+ n))
+
+(defun strip-docstring-indent (docstring indentation first-line-special-p)
+ (with-output-to-string (out)
+ (with-input-from-string (s docstring)
+ (loop for i upfrom 0
+ do (multiple-value-bind (line missing-newline-p)
+ (read-line s nil nil)
+ (unless line
+ (return))
+ (write-string (if (and first-line-special-p
+ (zerop i))
+ line
+ (subseq line (min (length line)
+ indentation)))
+ out)
+ (unless missing-newline-p
+ (terpri out)))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL