Hunchentoot-make-docstrings

Here's a longer example, from "Hunchentoot" version 1.2.18 (BSD license), file "make-docstrings.lisp".

First, we'll show a sweet-expression version, followed by the original s-expression form.

Sweet-expressions

;; -*- Lisp -*-

defpackage :make-docstrings :use(:cl) :export(#:parse-doc)

in-package :make-docstrings

defclass formatting-stream
  (trivial-gray-streams:fundamental-character-input-stream)
  \\
    understream :initarg :understream
                :reader \\ understream
    width :initarg :width
          :initform
          \\ error "missing :width argument to formatting-stream creation"
          :reader \\ width
    column :initform 0
           :accessor \\ column
    word-wrap-p :initform t
                :accessor \\ word-wrap-p
    word-buffer
                :initform
                \\ make-array 1000 :element-type 'character
                                   :adjustable \\ t
                                   :fill-pointer \\ 0
                :reader \\ word-buffer

defun write-char% (char stream)
  incf column(stream)
  write-char char understream(stream)

defun print-newline (stream)
  write-char #\newline understream(stream)
  setf column(stream) 0

defun buffer-not-empty-p (stream)
  plusp length(word-buffer(stream))

defun maybe-flush-word (stream)
  when buffer-not-empty-p(stream)
    cond
      {width(stream) < {column(stream) + length(word-buffer(stream))}}
        print-newline stream
      plusp(column(stream)) write-char%(#\space stream)
    loop for char across word-buffer(stream) do
      write-char% char stream
    setf fill-pointer(word-buffer(stream)) 0

defmethod trivial-gray-streams:stream-write-char
  stream(formatting-stream) char
  if word-wrap-p(stream)
    cond
      eql(#\space char) maybe-flush-word(stream)
      eql(#\newline char)
        maybe-flush-word stream
        print-newline stream
      t vector-push-extend(char word-buffer(stream))
    write-char char understream(stream)

defmethod trivial-gray-streams:stream-line-column
  stream()
  {column(stream) + length(word-buffer(stream))}

defmethod trivial-gray-streams:stream-write-string
  stream(formatting-stream) string &optional start end
  loop for i from {start or 0} below {end or length(string)} do
    write-char char(string i) stream

defmethod trivial-gray-streams:stream-terpri
  (stream(formatting-stream))
  write-char #\newline stream

defmethod close
  stream(formatting-stream) &key abort
  unless abort maybe-flush-word(stream)

defmethod setf(word-wrap-p)
  :before
  new-value stream(formatting-stream)
  maybe-flush-word stream
  when buffer-not-empty-p(stream) print-newline(stream)

defun test-wrap-stream (text)
  with-output-to-string
    s()
    with-open-stream
      s $ make-instance 'formatting-stream :understream s :width 20
      write-string text s
      setf word-wrap-p(s) nil
      format s "~&OFF~%"
      write-string text s
      format s "~&ON~%"
      setf word-wrap-p(s) t
      write-string text s

defmacro replace-regexp (place regex replacement)
  ` setf ,place
         cl-ppcre:regex-replace-all ,regex ,place ,replacement

defun collapse-whitespace (string)
  replace-regexp
    string
    "[ \\t]*\\n[ \\t]*"
    #.make-string(1 :initial-element #\newline)
  replace-regexp string "(?
    if eq(basic-type :function)
      if stp:attribute-value(node "generic")
        :generic-function
        :function
      basic-type

defun skip-to (stream char)
  loop until eql(char peek-char(nil stream)) do
    read-char stream

defun get-simple-def-docstring (source-string position)
  with-input-from-string
    s source-string :start 1+(position)
    read s
    read s
    read s
    skip-to s #\"
    list :start file-position(s) :text read(s) :end file-position(s)

defun get-complex-def-docstring (source-string position)
  with-input-from-string
    s source-string :start 1+(position)
    read s
    read s
    read s
    loop
      let* <* start-of-clause $ file-position s \\ clause $ read s *>
        when eql(first(clause) :documentation)
        ! file-position s start-of-clause
        ! skip-to s #\(
        ! read-char s
        ! read s
        ! skip-to s #\"
        ! return
        !   list :start file-position(s) :text read(s) :end file-position(s)

defun get-doc-function (type)
  case type
    :function(:special-variable) 'get-simple-def-docstring
    :generic-function(:class) 'get-complex-def-docstring

defun source-location-flatten (location-info)
  apply
    #'append
    rest find(:location rest(location-info) :key #'first)

defvar *files*

defclass file ()
  \\
    file-pathname :initarg :file-pathname :reader file-pathname
    docstrings :initform nil :accessor docstrings
    contents :accessor contents

defmethod initialize-instance
  :after
  file(file) &key file-pathname
  setf
    slot-value file 'contents
    alexandria:read-file-into-string file-pathname

defun get-file (pathname)
  or
    gethash pathname *files*
    setf
      gethash pathname *files*
      make-instance 'file :file-pathname pathname

defun record-docstring (doc-docstring get-doc-function symbol-name)
  let
    \\
      definitions
        remove-if
          lambda definition()
          ! or
          !   cl-ppcre:scan "(?i)^\\s*\\(defmethod\\s" first(definition)
          !   eql first(second(definition)) :error
          swank:find-definitions-for-emacs symbol-name
    case length(definitions)
      0 warn("no source location for ~A" symbol-name)
      1
        let*
          \\
            source-location $ source-location-flatten first(definitions)
            file $ get-file getf(source-location :file)
          push
            list*
              :doc-docstring
              doc-docstring
              funcall
                get-doc-function
                contents file
                getf source-location :position
            docstrings file
      2 warn("multiple source locations for ~A" symbol-name)

defun parse-doc (pathname default-package-name)
  let <* *files* $ make-hash-table :test #'equal *>
    xpath:with-namespaces
      (("clix" "http://bknr.net/clixdoc"))
      xpath:do-node-set
        node
          xpath:evaluate
            "//*[clix:description!='']"
            cxml:parse pathname stp:make-builder()
        let
          \\
            type $ get-doc-entry-type node
            symbol-name
              maybe-qualify-name
                stp:attribute-value node "name"
                default-package-name
          xpath:do-node-set
            description xpath:evaluate("clix:description" node)
            alexandria:when-let
              get-doc-function get-doc-function(type)
              record-docstring
                xml-to-docstring description
                get-doc-function
                symbol-name
    *files*

S-expression version

;; -*- Lisp -*-

(defpackage :make-docstrings
  (:use :cl)
  (:export #:parse-doc))

(in-package :make-docstrings)

(defclass formatting-stream (trivial-gray-streams:fundamental-character-input-stream)
  ((understream :initarg :understream
                :reader understream)
   (width :initarg :width
          :initform (error "missing :width argument to formatting-stream creation")
          :reader width)
   (column :initform 0
           :accessor column)
   (word-wrap-p :initform t
                :accessor word-wrap-p)
   (word-buffer :initform (make-array 1000
                                      :element-type 'character
                                      :adjustable t
                                      :fill-pointer 0)
                :reader word-buffer)))

(defun write-char% (char stream)
  (incf (column stream))
  (write-char char (understream stream)))

(defun print-newline (stream)
  (write-char #\Newline (understream stream))
  (setf (column stream) 0))

(defun buffer-not-empty-p (stream)
  (plusp (length (word-buffer stream))))

(defun maybe-flush-word (stream)
  (when (buffer-not-empty-p stream)
    (cond
      ((< (width stream) (+ (column stream) (length (word-buffer stream))))
       (print-newline stream))
      ((plusp (column stream))
       (write-char% #\Space stream)))
    (loop for char across (word-buffer stream)
          do (write-char% char stream))
    (setf (fill-pointer (word-buffer stream)) 0)))

(defmethod trivial-gray-streams:stream-write-char ((stream formatting-stream) char)
  (if (word-wrap-p stream)
      (cond
        ((eql #\Space char)
         (maybe-flush-word stream))
        ((eql #\Newline char)
         (maybe-flush-word stream)
         (print-newline stream))
        (t
         (vector-push-extend char (word-buffer stream))))
      (write-char char (understream stream))))

(defmethod trivial-gray-streams:stream-line-column (stream)
  (+ (column stream) (length (word-buffer stream))))

(defmethod trivial-gray-streams:stream-write-string ((stream formatting-stream) string &optional start end)
  (loop for i from (or start 0) below (or end (length string))
        do (write-char (char string i) stream)))

(defmethod trivial-gray-streams:stream-terpri ((stream formatting-stream))
  (write-char #\Newline stream))

(defmethod close ((stream formatting-stream) &key abort)
  (unless abort
    (maybe-flush-word stream)))

(defmethod (setf word-wrap-p) :before (new-value (stream formatting-stream))
  (maybe-flush-word stream)
  (when (buffer-not-empty-p stream)
    (print-newline stream)))

(defun test-wrap-stream (text)
  (with-output-to-string (s)
    (with-open-stream (s (make-instance 'formatting-stream :understream s :width 20))
      (write-string text s)
      (setf (word-wrap-p s) nil)
      (format s "~&OFF~%")
      (write-string text s)
      (format s "~&ON~%")
      (setf (word-wrap-p s) t)
      (write-string text s))))

(defmacro replace-regexp (place regex replacement)
  `(setf ,place (cl-ppcre:regex-replace-all ,regex ,place ,replacement)))

(defun collapse-whitespace (string)
  (replace-regexp string "[ \\t]*\\n[ \\t]*" #.(make-string 1 :initial-element #\Newline))
  (replace-regexp string "(?