(require 'slime)
(require 'advice)
(require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library.

(define-slime-contrib slime-references
  "Clickable references to documentation (SBCL only)."
  (:authors "Christophe Rhodes  <csr21@cantab.net>"
            "Luke Gorrie  <luke@bluetail.com>"
            "Tobias C. Rittweiler <tcr@freebits.de>")
  (:license "GPL")
  (:on-load
   (ad-enable-advice 'slime-note.message 'after 'slime-note.message+references)
   (ad-activate 'slime-note.message)
   (setq slime-tree-printer 'slime-tree-print-with-references)
   (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
  (:on-unload
   (ad-disable-advice 'slime-note.message 'after 'slime-note.message+references)
   (ad-deactivate 'slime-note.message)
   (setq slime-tree-printer 'slime-tree-default-printer)
   (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)))

(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/"
  "*The base URL of the SBCL manual, for documentation lookup."
  :type '(choice (string :tag "HTML Documentation")
                 (const :tag "Info Documentation" :info))
  :group 'slime-mode)

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


;;;;; SBCL-style references

(defvar slime-references-local-keymap
  (let ((map (make-sparse-keymap "local keymap for slime references")))
    (define-key map [mouse-2] 'slime-lookup-reference-at-mouse)
    (define-key map [return] 'slime-lookup-reference-at-point)
    map))

(defun slime-reference-properties (reference)
  "Return the properties for a reference.
Only add clickability to properties we actually know how to lookup."
  (cl-destructuring-bind (where type what) reference
    (if (or (and (eq where :sbcl) (eq type :node))
            (and (eq where :ansi-cl)
                 (memq type '(:function :special-operator :macro
                                        :type :system-class
                                        :section :glossary :issue))))
        `(slime-reference ,reference
                          font-lock-face sldb-reference-face
                          follow-link t
                          mouse-face highlight
                          help-echo "mouse-2: visit documentation."
                          keymap ,slime-references-local-keymap))))

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

(defun slime-insert-references (references)
  (when references
    (insert "\nSee also:")
    (slime-with-rigid-indentation 2
      (mapc #'slime-insert-reference references))))

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

(defun slime-format-reference-node (what)
  (if (listp what)
      (mapconcat #'prin1-to-string what ".")
    what))

(defun slime-lookup-reference-at-point ()
  "Browse the documentation reference at point."
  (interactive)
  (let ((refs (get-text-property (point) 'slime-reference)))
    (if (null refs)
        (error "No references at point")
      (cl-destructuring-bind (where type what) refs
        (cl-case where
          (:ansi-cl
           (cl-case type
             (:section
              (browse-url (funcall common-lisp-hyperspec-section-fun what)))
             (:glossary
              (browse-url (funcall common-lisp-hyperspec-glossary-function what)))
             (:issue
              (browse-url (common-lisp-issuex what)))
             (:special-operator
              (browse-url (common-lisp-special-operator (downcase name))))
             (t
              (hyperspec-lookup what))))
          (t
           (case slime-sbcl-manual-root
             (:info
              (info (format "(sbcl)%s" what)))
             (t
              (browse-url
               (format "%s#%s" slime-sbcl-manual-root
                       (subst-char-in-string ?\  ?\- what)))))))))))

(defun slime-lookup-reference-at-mouse (event)
  "Invoke the action pointed at by the mouse."
  (interactive "e")
  (cl-destructuring-bind (mouse-1 (w pos . _) . _) event
    (save-excursion
      (goto-char pos)
      (slime-lookup-reference-at-point))))

;;;;; Hook into *SLIME COMPILATION*

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

;;; FIXME: `compilation-mode' will swallow the `mouse-face'
;;; etc. properties.
(defadvice slime-note.message (after slime-note.message+references)
  (setq ad-return-value
        (concat ad-return-value
                (with-temp-buffer
                  (slime-insert-references
                   (slime-note.references (ad-get-arg 0)))
                  (buffer-string)))))

;;;;; Hook into slime-compiler-notes-tree

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

;;;;; Hook into SLDB

(defun sldb-maybe-insert-references (extra)
  (slime-dcase extra
    ((:references references) (slime-insert-references references) t)
    (t nil)))

(provide 'slime-references)