;;; hyperspec.el
;;; Copyright (c) 2006 Devon Sean McCullough
;;; Licensed under the GPL (GNU Public License)
;;; inspired by code from gcl-info/get-gcl-info.el

;;; This library was meant to facilitate access to the
;;; Common Lisp HyperSpec(TM) (C) 1996-2005 LispWorks Ltd.
;;; however I was unable to locate an info-ized copy online,
;;; if anyone knows where I can get it, do let me know please.

;;; ^H^Y hyperspec lookup Common Lisp .../gcl-info/*
;;; can use the GCL (Gnu Common Lisp) manual which
;;; emacs can download by M-x (or ESC x) commands, e.g.,
;;; describe-variable Info-directory-list
;;; dired /usr/local/info or wherever you put it,
;;; copy-file /ftp.ma.utexas.edu:/pub/gcl/gcl.info.tgz
;;; (or ftp://ftp.ma.utexas.edu/pub/gcl/gcl-info+texi.tgz
;;; with source)
;;; shell-command tar -xpzf gcl-info.tgz to unpack.
;;; The GCL info has bugs, e.g., defparameter and defvar
;;; share a node but only the former is indexed.

(require 'cl)
(require 'info)

(global-set-key "\^H\^Y"      'hyperspec)     ; Common Lisp Hyperspec(TM)
(global-set-key "\^Hy"        'hyperspec)     ; Common Lisp Hyperspec(TM)

(defvar hyperspec-info-dir "/usr/local/info/gcl-info/")
(defvar hyperspec-info-file "gcl.info")
;(defvar hyperspec-info-dir "/usr/local/share/info/gcl-info/")

(pushnew hyperspec-info-dir Info-directory-list :test 'equal)

(defun hyperspec-nodes-from-tags ()
  "Parse Common Lisp manual tag table and return alist of nodes."
  ;; does completing reader really need alist of ("eq" . "eq") like this ???
  (save-excursion
    (set-buffer
     (find-file-noselect
      (expand-file-name hyperspec-info-file
			hyperspec-info-dir)))
    (widen)
    (goto-char (point-min))
    (and
     (search-forward "Tag Table:" nil t)
     (search-forward "Node:" nil t)
     (let ((nodes '()))
       (beginning-of-line)
       (while (looking-at "Node: \\([^\n]*\\)\^?")
         (push (let ((node (buffer-substring
                            (match-beginning 1)
                            (match-end 1))))
                 (cons node node))
               nodes)
         (forward-line 1))
       (kill-buffer nil)
       (nreverse nodes)))))

(defvar hyperspec-completion-alist (hyperspec-nodes-from-tags)
  "Gnu Common Lisp info nodes in alist for completing reader.")
; (setq hyperspec-completion-alist (hyperspec-nodes-from-tags))

(defun hyperspec (symbol)
  "Look up symbol near point in the GNU Common Lisp manual.
In the future it is hoped to also support the Common Lisp HyperSpec(TM)"
  ;; For sake of local context and user symbols, maybe better done in swank ???
  ;; Maybe spell-check symbol names using doc as dictionary?
  (interactive
   (list
    (let* ((emacs-lisp-mode-syntax-table (syntax-table))
	   (completion-ignore-case t)
	   (default (or (hyperspec-parse-default #'hyperspec-symbol-at-point)
			(hyperspec-parse-default #'function-called-at-point)))
	   (given (when (or current-prefix-arg (not default))
		    (completing-read
		     (if (not default) "Common Lisp HyperSpec[TM] symbol: "
		       (format "Common Lisp HyperSpec[TM] symbol (default %s): "
			       (upcase default)))
		     hyperspec-completion-alist nil t nil nil default))))
      (or given
	  default
	  0))))
  (Info-goto-node
   (concat
    "(" hyperspec-info-file ")" (cond ((symbolp symbol) (symbol-name symbol))
				      ((numberp symbol) "")
				      (t symbol)))))

(defun hyperspec-parse-default (parser)
  "Parse and return a default string.  Return nil if nothing suitable."
  (let ((symbol (funcall parser)))
    (and symbol
         (car (assoc* (if (symbolp symbol)
			  (symbol-name symbol)
			symbol)
                      hyperspec-completion-alist
                      :test #'equalp)))))

(defun hyperspec-symbol-at-point ()
  "Return the string naming the symbol found around point
or nil if there is no such symbol."
  (condition-case ()
      (with-syntax-table emacs-lisp-mode-syntax-table
	(save-excursion
	  (or (not (zerop (skip-syntax-backward "_w")))
	      (looking-at "\\s'*\\(\\sw\\|\\s_\\)")
	      (forward-sexp -1))
	  (skip-chars-forward "#'")
	  (let ((obj (read (current-buffer))))
	    (and (symbolp obj) (symbol-name obj)))))
    (error nil)))

;;; end hyperspec.el