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 MIT web site as
6;;;   <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/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, 2017 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 "http://clhs.lisp.se/"
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.
41If you copy the HyperSpec to your local system, set this variable to
42something 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'.
105Actually, `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 &optional kill)
122  "Browse the Common Lisp HyperSpec documentation for SYMBOL-NAME.
123Finds the HyperSpec at `common-lisp-hyperspec-root'.
124With prefix arg, save the URL in the `kill-ring' instead."
125  (interactive (list (let ((sym (thing-at-point 'symbol t))
126                           (completion-ignore-case t))
127                       (completing-read
128                        "Look-up symbol in the Common Lisp HyperSpec: "
129                        #'hash-table-complete (clhs-symbols)
130                        t sym 'clhs-history))
131                     current-prefix-arg))
132  (unless (= ?/ (aref common-lisp-hyperspec-root
133                      (1- (length common-lisp-hyperspec-root))))
134    (setq common-lisp-hyperspec-root
135          (concat common-lisp-hyperspec-root "/")))
136  (let ((url (concat common-lisp-hyperspec-root
137                     (gethash (upcase symbol-name) (clhs-symbols)))))
138    (if kill
139        (kill-new url)
140      (browse-url url))))
141
142(provide 'clhs)
143