site-lisp/clhs.el

   1 ;;; clhs.el -- access the Common Lisp HyperSpec (CLHS)
   2
   3 ;;; this works with both
   4 ;;; * the "long file name" version released by Harlequin and available
   5 ;;;   at the ALU (Association of Lisp Users) web site as
   6 ;;;   <http://www.lisp.org/HyperSpec/FrontMatter/> and
   7 ;;; * the "8.3 file name" version released later by Xanalys and available at
   8 ;;;   <http://www.xanalys.com/software_tools/reference/HyperSpec/>
   9 ;;;   and downloadable as
  10 ;;;   <http://www.xanalys.com/software_tools/reference/HyperSpec/HyperSpec-6-0.tar.gz>
  11 ;;; This is accomplished by not hard-wiring the symbol->file table
  12 ;;; but reading the Data/<map> file instead
  13
  14 ;;; Copyright (C) 2002-2008 Sam Steingold <sds@gnu.org>
  15 ;;; Keywords: lisp, common lisp, emacs, ANSI CL, hyperspec
  16 ;;; released under the GNU GPL <http://www.gnu.org/copyleft/gpl.html>
  17 ;;; as a part of GNU CLISP <http://clisp.cons.org>, <http://www.clisp.org>
  18
  19 ;;; Commentary:
  20
  21 ;; Kent Pitman and the Harlequin Group (later Xanalys) have made the
  22 ;; text of the "American National Standard for Information Technology --
  23 ;; Programming Language -- Common Lisp", ANSI X3.226-1994 available on
  24 ;; the WWW, in the form of the Common Lisp HyperSpec.  This package
  25 ;; makes it convenient to peruse this documentation from within Emacs.
  26
  27 ;; This is inspired by the Erik Naggum's version of 1997.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl)) ; push
  32 (require 'browse-url)
  33 (require 'thingatpt)
  34 (require 'url)
  35
  36 (defcustom common-lisp-hyperspec-root
  37   "http://www.lispworks.com/documentation/HyperSpec/"
  38   ;; "http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/html/hyperspec/HyperSpec/"
  39   ;; "http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/"
  40   "*The root of the Common Lisp HyperSpec URL.
  41 If you copy the HyperSpec to your local system, set this variable to
  42 something like \"file:/usr/local/doc/HyperSpec/\"."
  43   :group 'lisp
  44   :type 'string)
  45
  46 (defvar clhs-history nil
  47   "History of symbols looked up in the Common Lisp HyperSpec so far.")
  48
  49 (defvar clhs-symbols nil)
  50
  51 (defun clhs-table-buffer (&optional root)
  52   (unless root (setq root common-lisp-hyperspec-root))
  53   (if (string-match "^file:/" root)
  54       (with-current-buffer (get-buffer-create " *clhs-tmp-buf*")
  55         (insert-file-contents-literally
  56          (let* ((d (concat (substring root 6) "/Data/"))
  57                 (f (concat d "Map_Sym.txt")))
  58            (if (file-exists-p f) f
  59              (setq f (concat d "Symbol-Table.text"))
  60              (if (file-exists-p f) f
  61                (error "no symbol table at %s" root))))
  62          nil nil nil t)
  63         (goto-char 0)
  64         (current-buffer))
  65     (let* ((d (concat root "/Data/"))
  66            (f (concat d "Map_Sym.txt")))
  67       (set-buffer (url-retrieve-synchronously f))
  68       (goto-char 0)
  69       (unless (looking-at "^HTTP/.*200 *OK$")
  70         (kill-buffer (current-buffer))
  71         (setq f (concat d "Symbol-Table.text"))
  72         (set-buffer (url-retrieve-synchronously f))
  73         (goto-char 0)
  74         (unless (looking-at "^HTTP/.*200 *OK$")
  75           (kill-buffer (current-buffer))
  76           (error "no symbol table at %s" root)))
  77       ;; skip to the first symbol
  78       (search-forward "\n\n")
  79       (current-buffer))))
  80
  81 (defun clhs-read-symbols ()
  82   "read `clhs-symbols' from the current position in the current buffer"
  83   (while (not (eobp))
  84     (puthash (buffer-substring-no-properties ; symbol
  85               (line-beginning-position) (line-end-position))
  86              (progn (forward-line 1) ; file name
  87                     (buffer-substring-no-properties ; strip "../"
  88                      (+ 3 (line-beginning-position)) (line-end-position)))
  89              clhs-symbols)
  90     (forward-line 1)))
  91
  92 (defun clhs-symbols ()
  93   "Get `clhs-symbols' from `common-lisp-hyperspec-root'."
  94   (if (and clhs-symbols (not (= 0 (hash-table-count clhs-symbols))))
  95       clhs-symbols
  96     (with-current-buffer (clhs-table-buffer)
  97       (unless clhs-symbols
  98         (setq clhs-symbols (make-hash-table :test 'equal :size 1031)))
  99       (clhs-read-symbols)
 100       (kill-buffer (current-buffer))
 101       clhs-symbols)))
 102
 103 (defun hash-table-complete (string table how)
 104   "This makes it possible to use hash-tables with `completing-read'.
 105 Actually, `completing-read' in Emacs 22 accepts hash-tables natively."
 106   (let ((res nil) (st (upcase string)) (len (length string)))
 107     (maphash (lambda (key val)
 108                (when (and (<= len (length key))
 109                           (string= st (substring key 0 len)))
 110                  (push key res)))
 111              table)
 112     (if how
 113         res                       ; `all-completions'
 114         (if (cdr res)
 115             (try-completion st (mapcar #'list res))
 116             (if (string= st (car res))
 117                 t
 118                 (car res))))))
 119
 120 ;;;###autoload
 121 (defun common-lisp-hyperspec (symbol-name)
 122   "Browse the Common Lisp HyperSpec documentation for SYMBOL-NAME.
 123 Finds the HyperSpec at `common-lisp-hyperspec-root'."
 124   (interactive (list (let ((sym (thing-at-point 'symbol))
 125                            (completion-ignore-case t))
 126                        (completing-read
 127                         "Look-up symbol in the Common Lisp HyperSpec: "
 128                         #'hash-table-complete (clhs-symbols)
 129                         t sym 'clhs-history))))
 130   (unless (= ?/ (aref common-lisp-hyperspec-root
 131                       (1- (length common-lisp-hyperspec-root))))
 132     (setq common-lisp-hyperspec-root
 133           (concat common-lisp-hyperspec-root "/")))
 134   (browse-url (concat common-lisp-hyperspec-root
 135                       (gethash (upcase symbol-name) (clhs-symbols)))))
 136
 137 (provide 'clhs)