hg.stevelosh.com > cl-nrepl

src/middleware/documentation.lisp @ 743c0a981785 

Oh boy, here we go...

Finally getting back to poking at this.  Apparently my Common Lisp has gotten
better in the past six months because good lord this code looks bad now.

Anyway, a few changes:

* Make it run on CCL by working around a usocket bug.
* Remove the workaround hacks.  It's never gonna work with Fireplace anyway.
* Make the socket stream once instead of on every read/write so the GC doesn't hate us.
author Steve Losh <steve@stevelosh.com>
date Sat, 09 Apr 2016 20:42:34 +0000
parents 15af562c7bca
children 3e9db801d234 
(in-package #:nrepl)

(defun lambda-list-to-string (l)
  "Return a single-line string of the lambda list."
  (if (listp l)
    (format nil "(~{~A~^ ~})" (mapcar #'lambda-list-to-string l))
    (princ-to-string l)))

(defun find-lambda-list (s)
  "Return the lambda list for the given symbol.

  Will return `nil` if none is found.  A second value is returned to indicate
  whether it was found.

  "
  (if (fboundp s)
    (values
      #+sbcl (sb-introspect:function-lambda-list s)
      #+ccl (ccl:arglist s)
      t)
    (values nil nil)))


(defun find-symbol-harder (name)
  "Return the symbol object with the given `name`.

  This should work with:

    FOO (assumes the current package)
    P:FOO (looks in package P)

  TODO: add support for:

    P::FOO
    :KEYWORD

  "
  (flet ((split-string (s delim)
           (let ((idx (position delim s)))
             (if idx
               (cons (subseq s 0 idx)
                     (subseq s (1+ idx)))
               (cons nil s)))))
    (destructuring-bind (pack . symb) (split-string (string-upcase name) #\:)
      (find-symbol symb (if pack
                          (find-package pack)
                          *package*)))))

(define-middleware wrap-documentation "documentation" message
  (let ((s (find-symbol-harder (fset:lookup message "symbol"))))
    (respond message
             (with-when
                 (make-map "status" '("done"))
               "type-docstring" (documentation s 'type)
               "structure-docstring" (documentation s 'structure)
               "variable-docstring" (documentation s 'variable)
               "setf-docstring" (documentation s 'setf)
               "function-docstring" (documentation s 'function)
               "function-arglist"
               (multiple-value-bind (arglist foundp)
                   (find-lambda-list s)
                 (when foundp
                   (princ-to-string (cons s arglist))))))))

(define-middleware wrap-arglist "arglist" message
  (let ((s (find-symbol-harder (fset:lookup message "symbol"))))
    (respond message
             (with-when
                 (make-map "status" '("done"))
               "function-arglist"
               (multiple-value-bind (arglist foundp)
                   (find-lambda-list s)
                 (when foundp
                   (lambda-list-to-string (cons s arglist))))))))