[slime-cvs] CVS slime/contrib

[heller]

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv18471/contrib

Modified Files:
	ChangeLog 
Added Files:
	slime-references.el 
Log Message:
Move SBCL doc references to contrib.

* slime.el (sldb-insert-condition): Merge REFERENCES and EXTRAS.
(sldb-extras-hooks, sldb-dispatch-extras): New hook.

* swank.lisp (debugger-condition-for-emacs): Merge REFERENCES and EXTRAS.

* swank-backend.lisp (condition-references): Removed. Merged with
condition-extras.

* swank-sbcl.lisp (condition-references): Removed.
(condition-extras): Include references.
(externalize-reference): New function.  Don't return plain
symbols.

* swank-allegro.lisp (condition-references): Removed.

* contrib/slime-references.el: New file.



--- /project/slime/cvsroot/slime/contrib/ChangeLog	2007/09/10 11:01:09	1.39
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2007/09/10 15:39:05	1.40
@@ -1,3 +1,9 @@
+2007-09-10  Helmut Eller  <heller at common-lisp.net>
+
+	Move SBCL doc references to contrib.
+
+	* slime-references.el: New file.
+
 2007-09-10  Attila Lendvai  <attila.lendvai at gmail.com>
 
 	* slime-fuzzy.el: Fixed some race condition that prevented a

--- /project/slime/cvsroot/slime/contrib/slime-references.el	2007/09/10 15:39:05	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-references.el	2007/09/10 15:39:05	1.1
;;; slime-references.el --- Clickable references to documentation (SBCL only)
;;
;; Authors: Christophe Rhodes  <csr21 at cantab.net>
;;          Luke Gorrie  <luke at bluetail.com>
;;
;; License: GNU GPL (same license as Emacs)
;;
;;;

(defface sldb-reference-face 
  (list (list t (:underline t)))
  "Face for references."
  :group 'slime-debugger)

(defun slime-note.references (note)
  (plist-get note :references))

(defun slime-tree-print-with-references (tree)
  ;; for SBCL-style references
  (slime-tree-default-printer tree)
  (when-let (note (plist-get (slime-tree.plist tree) 'note))
    (when-let (references (slime-note.references note))
      (terpri (current-buffer))
      (princ "See also:" (current-buffer))
      (terpri (current-buffer))
      (slime-tree-insert-references references))))

(defun slime-tree-insert-references (references)
  "Insert documentation references from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
  (loop for refs on references
        for ref = (car refs)
        do
        (destructuring-bind (where type what) ref
          ;; FIXME: this is poorly factored, and shares some code and
          ;; data with sldb that it shouldn't: notably
          ;; sldb-reference-face.  Probably the names of
          ;; sldb-reference-foo should be altered to be not sldb
          ;; specific.
          (insert "  " (sldb-format-reference-source where) ", ")
          (slime-insert-propertized (sldb-reference-properties ref)
                                    (sldb-format-reference-node what))
          (insert (format " [%s]" type))
          (when (cdr refs)
            (terpri (current-buffer))))))



;;;;; SLDB references (rather SBCL specific)

(defun sldb-insert-references (references)
  "Insert documentation references from a condition.
See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
  (loop for ref in references do
        (destructuring-bind (where type what) ref
          (insert (sldb-format-reference-source where) ", ")
          (slime-insert-propertized (sldb-reference-properties ref)
                                    (sldb-format-reference-node what))
          (insert (format " [%s]" type) "\n"))))

(defun sldb-reference-properties (reference)
  "Return the properties for a reference.
Only add clickability to properties we actually know how to lookup."
  (destructuring-bind (where type what) reference
    (if (or (and (eq where :sbcl) (eq type :node))
            (and (eq where :ansi-cl)
                 (member type '("FUNCTION" "SPECIAL-OPERATOR" "MACRO"
				"SECTION" "GLOSSARY" "ISSUE"))))
        `(sldb-default-action
          sldb-lookup-reference
          ;; FIXME: this is a hack!  slime-compiler-notes and sldb are a
          ;; little too intimately entwined.
          slime-compiler-notes-default-action sldb-lookup-reference
          sldb-reference ,reference
          face sldb-reference-face
          mouse-face highlight))))

(defun sldb-format-reference-source (where)
  (case where
    (:amop    "The Art of the Metaobject Protocol")
    (:ansi-cl "Common Lisp Hyperspec")
    (:sbcl    "SBCL Manual")
    (t        (format "%S" where))))

(defun sldb-format-reference-node (what)
  (if (listp what)
      (mapconcat (lambda (x) (format "%s" x)) what ".")
    what))

(defun sldb-lookup-reference ()
  "Browse the documentation reference at point."
  (destructuring-bind (where type what)
      (get-text-property (point) 'sldb-reference)
    (case where
      (:ansi-cl
       (case type
         (:section
          (browse-url (funcall common-lisp-hyperspec-section-fun what)))
         (:glossary
          (browse-url (funcall common-lisp-glossary-fun what)))
         (:issue
          (browse-url (funcall 'common-lisp-issuex what)))
         (t
          (hyperspec-lookup what))))
      (t
       (let ((url (format "%s%s.html" slime-sbcl-manual-root
                          (subst-char-in-string ?\  ?\- what))))
         (browse-url url))))))

(defun sldb-maybe-insert-references (extra)
  (destructure-case extra
    ((:references references)
     (when references
       (insert "See also:\n")
       (slime-with-rigid-indentation 2
	 (sldb-insert-references references))
       (insert "\n"))
     t)
    (t nil)))


;;; Initialization

(setq slime-tree-printer 'slime-tree-print-with-references)

(add-hook sldb-extras-hooks 'sldb-maybe-insert-references)

(provide 'slime-references)