Documentation generated by lispdoc running on ~a
" (lisp-implementation-type)) (format out "")))))) (defun lispdoc-package (package) (let (symbols) (do-external-symbols (x package) (push x symbols)) (setf symbols (sort symbols #'string-lessp)) (append `(:package ,(package-name package) ,(or (documentation package t) :undocumented)) (reduce #'append (mapcar #'lispdoc-symbol symbols))))) (defun has-meaning (symbol) (or (boundp symbol) (fboundp symbol) (ignore-errors (find-class symbol)))) (defun symbol-name-tree (x) (cond ((null x) '()) ((symbolp x) (if (and (null (symbol-package x)) (char= #\G (char (symbol-name x) 0))) ;; trying to filter out gensyms ;; hoping there is only one of these per arglist "x" (string-downcase (symbol-name x)))) ((stringp x) (string-downcase x)) ((numberp x) (princ-to-string x)) ((listp x) (mapcar #'symbol-name-tree x)) (t (error "unknown tree element")))) (defun lispdoc-symbol (symbol) (let (doc) (when (documentation symbol 'variable) (push `(:variable ,(symbol-name symbol) ,(documentation symbol 'variable) ,(if (boundp symbol) (symbol-value symbol) :unbound)) doc)) (let ((spec `(setf ,symbol))) (when (documentation spec 'function) (if (and (fboundp spec) (typep (fdefinition spec) 'standard-generic-function)) (push `(:generic-function (setf ,(symbol-name symbol)) ,(symbol-name-tree #+openmcl(ccl:arglist spec) #+lispworks(lw:function-lambda-list spec)) ,(documentation spec 'function)) doc) (push `(:function (setf ,(symbol-name symbol)) ,(symbol-name-tree #+openmcl(ccl:arglist spec) #+lispworks(lw:function-lambda-list spec)) ,(documentation spec 'function)) doc)))) (when (documentation symbol 'function) (if (and (fboundp symbol) (typep (fdefinition symbol) 'standard-generic-function)) (push `(:generic-function ,(symbol-name symbol) ,(symbol-name-tree #+openmcl(ccl:arglist symbol) #+lispworks(lw:function-lambda-list symbol)) ,(documentation symbol 'function)) doc) (push `(:function ,(symbol-name symbol) ,(symbol-name-tree #+openmcl(ccl:arglist symbol) #+lispworks(lw:function-lambda-list symbol)) ,(documentation symbol 'function)) doc))) (when (documentation symbol 'type) (cond ((subtypep (find-class symbol) (find-class 'condition)) (push `(:condition ,(symbol-name symbol) ,(documentation symbol 'type) ,(symbol-name-tree (mapcar #'class-name #+openmcl(ccl:class-precedence-list (find-class symbol)) #+lispworks(hcl:class-precedence-list (find-class symbol)))) ,(mapcar #'string-downcase (mapcar #'prin1-to-string #+openmcl(ccl::class-slot-initargs (find-class symbol)) #+lispworks(lw-tools::class-initargs (find-class symbol))))) doc)) ((subtypep (find-class symbol) (find-class 'standard-object)) (push `(:class ,(symbol-name symbol) ,(documentation symbol 'type) ,(symbol-name-tree (mapcar #'class-name #+openmcl(ccl:class-precedence-list (find-class symbol)) #+lispworks(hcl:class-precedence-list (find-class symbol)))) ,(mapcar #'(lambda (x) (format nil ":~a" (string-downcase (symbol-name x)))) #+openmcl(ccl::class-slot-initargs (find-class symbol)) #+lispworks(lw-tools::class-initargs (find-class symbol)))) doc)) ((subtypep (find-class symbol) (find-class 'structure-object)) (push `(:structure ,(symbol-name symbol) ,(documentation symbol 'type)) doc)))) (or doc `((,(if (has-meaning symbol) :undocumented :skip) ,(symbol-name symbol)))))) (defun render-html-links (text) (loop with target = nil for pos = (search "`" text :test #'char=) for pos2 = (if pos (search "'" text :start2 pos :test #'char=)) when pos do (setq target (cons (let ((label (subseq text (1+ pos) pos2))) (format nil "~a~a" (subseq text 0 pos) label label)) target)) (setq text (subseq text (1+ pos2))) ;; the replacement is always longer than the replaced text ;; so old-pos does not need updating while pos finally (return (apply #'concatenate 'string (reverse (cons text target)))))) ;; (render-html-links "Hello `world' how are `you'?") text ) (defun render-html (lispdoc &optional (stream t)) "Generate a HTML fragment for the lispdoc sexp" (dolist (packagedoc lispdoc) (format stream "~a~%" (second packagedoc) (third packagedoc)) (dolist (symboldoc (nthcdr 3 packagedoc)) (ecase (first symboldoc) ((:function :generic-function) (destructuring-bind (type name arglist docstring) symboldoc (if (and (consp name) (eq (car name) 'setf)) (progn (format stream "
(setf (~a" (symbol-name-tree (second name))) (format stream " ~a~{ ~a~}) ~a)" (first (rest arglist)) (rest (rest arglist)) (first arglist))) (progn (format stream "
(~a" (symbol-name-tree name)) (if (null arglist) (format stream ")") (format stream " ~a~{ ~a~})" (first arglist) (rest arglist))))) (format stream " ~a
~%~a" (string-downcase type) (render-html-links docstring)))) (:variable (format stream "
~a ~a
~%~a~%" (symbol-name-tree (second symboldoc)) (string-downcase (first symboldoc)) (third symboldoc)) (if (eq (fourth symboldoc) :unbound) (format stream "
Initially unbound") (format stream "
Initial value: ~s~%" (fourth symboldoc)))) ((:class :condition :structure) (format stream "
~a ~a
~%~a" (symbol-name-tree (second symboldoc)) (string-downcase (first symboldoc)) (third symboldoc)) (when (fourth symboldoc) (format stream "
Class precedence list: ~{ ~a~}~%" (fourth symboldoc))) (when (fifth symboldoc) (format stream "
Class init args: ~{ ~a~}~%" (fifth symboldoc)))) (:skip (format t "~&;; warning: lispdoc skipping ~s~%" (second symboldoc))) (:undocumented (format stream "
~a
undocumented~%" (second symboldoc))))))) ;;;; eof