SLIME arglist types

swank-arglists.lisp

(defun print-decoded-arglist (arglist &key operator provided-args highlight types)
  (let ((first-space-after-operator (and operator t))
        (argument-types (car types))
        (return-type (cdr types)))
    (pprint-logical-block (nil nil)
    (macrolet ((space ()
                 ;; Kludge: When OPERATOR is not given, we don't want to
                 ;; print a space for the first argument.
                 `(if (not operator)
                      (setq operator t)
                      (progn (write-char #\space)
                             (if first-space-after-operator
                                 (setq first-space-after-operator nil)
                                 (pprint-newline :fill)))))
               (with-highlighting ((&key index) &body body)
                 `(if (eql ,index (car highlight))
                      (progn (princ "===> ") ,@body (princ " <==="))
                      (progn ,@body)))
               (print-arglist-recursively (argl &key index)
                 `(if (eql ,index (car highlight))
                      (print-decoded-arglist ,argl :highlight (cdr highlight))
                      (print-decoded-arglist ,argl)))
               (print-with-type ((type) &body body)
                 `(if (or (null ,type) (eq ,type 't))
                      (progn ,@body)
                      (pprint-logical-block (nil nil :prefix "[" :suffix "]")
                        ,@body
                        (let ((*print-pretty* t))
                          (format t " : ~S" ,type))))))
      (let ((index 0))
        (pprint-logical-block (nil nil :prefix "(" :suffix ")")
          (when operator
            (print-arg operator)
            (pprint-indent :current 1)) ; 1 due to possibly added space
          (do-decoded-arglist (remove-given-args arglist provided-args)
            (&provided (arg)
                       (space)
                       (print-arg arg :literal-strings t)
                       (incf index))
            (&required (arg)
                       (space)
                       (if (arglist-p arg)
                           (print-arglist-recursively arg :index index)
                           (with-highlighting (:index index)
                             (print-with-type ((nth-argument-type index argument-types))
                                              (print-arg arg))))
                       (incf index))
            (&optional :initially
                       (when (arglist.optional-args arglist)
                         (space)
                         (princ '&optional)))
            (&optional (arg init-value)
                       (space)
                       (if (arglist-p arg)
                           (print-arglist-recursively arg :index index)
                           (with-highlighting (:index index)
                             (print-with-type ((nth-argument-type index argument-types))
                               (if (null init-value)
                                   (print-arg arg)
                                   (format t "~:@<~A ~A~@:>"
                                           (undummy arg) (undummy init-value))))))
                       (incf index))
            (&key :initially
                  (when (arglist.key-p arglist)
                    (space)
                    (princ '&key)))
            (&key (keyword arg init)
                  (space)
                  (if (arglist-p arg)
                      (pprint-logical-block (nil nil :prefix "(" :suffix ")")
                        (prin1 keyword) (space)
                        (print-arglist-recursively arg :index keyword))
                      (print-with-type ((keyword-argument-type keyword argument-types))
                        (with-highlighting (:index keyword)
                          (cond ((and init (keywordp keyword))
                                 (format t "~:@<~A ~A~@:>" keyword (undummy init)))
                                (init
                                 (format t "~:@<(~A ..)~@:>"
                                         (undummy keyword) (undummy init)))
                                ((not (keywordp keyword))
                                 (format t "~:@<(~S ..)~@:>" keyword))
                                (t
                                 (princ keyword)))))))
            (&key :finally
                  (when (arglist.allow-other-keys-p arglist)
                    (space)
                    (princ '&allow-other-keys)))
            (&any :initially
                  (when (arglist.any-p arglist)
                    (space)
                    (princ '&any)))
            (&any (arg)
                  (space)
                  (print-arg arg))
            (&rest (args bodyp)
                   (space)
                   (princ (if bodyp '&body '&rest))
                   (space)
                   (if (arglist-p args)
                       (print-arglist-recursively args :index index)
                       (with-highlighting (:index index)
                         (print-arg args))))))
        ;; FIXME: add &UNKNOWN-JUNK?
        (unless (null return-type)
          (pprint-newline :linear)
          (pprint-logical-block (nil nil)
            (when (and (listp return-type)
                       (= 3 (length return-type))
                       (eql (first return-type) 'values)
                       (eql (third return-type) '&optional))
              (setf return-type (second return-type)))
            (format t " : ~S" return-type))))))))

(defun decoded-arglist-to-string (decoded-arglist
                                  &key operator highlight
                                  print-right-margin types)
  (with-output-to-string (*standard-output*)
    (with-arglist-io-syntax
      (let ((*print-right-margin* print-right-margin))
        (print-decoded-arglist decoded-arglist
                               :operator operator
                               :highlight highlight
                               :types types)))))

(defun decode-arglist (arglist &key parsing-type)
  "Parse the list ARGLIST and return an ARGLIST structure."
  (if (eq arglist :not-available)
      :not-available
      (loop
        with mode = nil
        with result = (make-arglist)
        for arg = (if (consp arglist)
                      (pop arglist)
                      (progn
                        (prog1 arglist
                          (setf mode '&rest
                                arglist nil))))
        do (cond
             ((eql mode '&unknown-junk)
              ;; don't leave this mode -- we don't know how the arglist
              ;; after unknown lambda-list keywords is interpreted
              (push arg (arglist.unknown-junk result)))
             ((eql arg '&allow-other-keys)
              (setf (arglist.allow-other-keys-p result) t))
             ((eql arg '&key)
              (setf (arglist.key-p result) t
                    mode arg))
             ((memq arg '(&optional &rest &body &aux))
              (setq mode arg))
             ((memq arg '(&whole &environment))
              (setq mode arg)
              (push arg (arglist.known-junk result)))
             ((and (symbolp arg)
                   (string= (symbol-name arg) (string '#:&any))) ; may be interned
              (setf (arglist.any-p result) t) ;  in any *package*.
              (setq mode '&any))
             ((memq arg lambda-list-keywords)
              (setq mode '&unknown-junk)
              (push arg (arglist.unknown-junk result)))
             (t
              (ecase mode
                (&key
                 (push (decode-keyword-arg arg)
                       (arglist.keyword-args result)))
                (&optional
                 (push (if parsing-type arg (decode-optional-arg arg))
                       (arglist.optional-args result)))
                (&body
                 (setf (arglist.body-p result) t
                       (arglist.rest result) arg))
                (&rest
                 (setf (arglist.rest result) arg))
                (&aux
                 (push (decode-optional-arg arg)
                       (arglist.aux-args result)))
                ((nil)
                 (push (if parsing-type arg (decode-required-arg arg))
                       (arglist.required-args result)))
                ((&whole &environment)
                 (setf mode nil)
                 (push arg (arglist.known-junk result)))
                (&any
                 (push arg (arglist.any-args result))))))
        until (null arglist)
        finally (nreversef (arglist.required-args result))
        finally (nreversef (arglist.optional-args result))
        finally (nreversef (arglist.keyword-args result))
        finally (nreversef (arglist.aux-args result))
        finally (nreversef (arglist.any-args result))
        finally (nreversef (arglist.known-junk result))
        finally (nreversef (arglist.unknown-junk result))
        finally (assert (or (and (not (arglist.key-p result))
                                 (not (arglist.any-p result)))
                            (exactly-one-p (arglist.key-p result)
                                           (arglist.any-p result))))
        finally (return result))))

(defslimefun autodoc (raw-form &key print-right-margin)
  "Return a list of two elements.
First, a string representing the arglist for the deepest subform in
RAW-FORM that does have an arglist. The highlighted parameter is
wrapped in ===> X <===.

Second, a boolean value telling whether the returned string can be cached."
  (handler-bind ((serious-condition
                  #'(lambda (c)
                      (unless (debug-on-swank-error)
                        (let ((*print-right-margin* print-right-margin))
                          (return-from autodoc
                            (format nil "Arglist Error: \"~A\"" c)))))))
    (with-buffer-syntax ()
      (multiple-value-bind (form arglist obj-at-cursor form-path)
          (find-subform-with-arglist (parse-raw-form raw-form))
        (cond ((boundp-and-interesting obj-at-cursor)
               (list (print-variable-to-string obj-at-cursor) nil))
              (t
               (list
                (with-available-arglist (arglist) arglist
                  (decoded-arglist-to-string
                   arglist
                   :print-right-margin print-right-margin
                   :operator (car form)
                   :highlight (form-path-to-arglist-path form-path
                                                         form
                                                         arglist)
                   :types
                   #+sbcl (if (and (symbolp (car form))
                                   (fboundp (car form))
                                   (not (macro-function (car form))))
                              (let ((derived-type (sb-impl::%fun-ftype (fdefinition (car form))))
                                    (declared-type (sb-impl::type-specifier (sb-impl::global-ftype (car form)))))
                                (if (and (listp derived-type) (listp (second derived-type)) (listp declared-type))
                                    (cons (decode-arglist (second declared-type) :parsing-type t)
                                          (third derived-type))
                                    nil)))
                   #-sbcl nil))
                t)))))))