1;;; erldoc.el --- browse Erlang/OTP documentation    -*- lexical-binding: t; -*-
2
3;; %CopyrightBegin%
4;;
5;; Copyright Ericsson AB 2016-2020. All Rights Reserved.
6;;
7;; Licensed under the Apache License, Version 2.0 (the "License");
8;; you may not use this file except in compliance with the License.
9;; You may obtain a copy of the License at
10;;
11;;     http://www.apache.org/licenses/LICENSE-2.0
12;;
13;; Unless required by applicable law or agreed to in writing, software
14;; distributed under the License is distributed on an "AS IS" BASIS,
15;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
16;; See the License for the specific language governing permissions and
17;; limitations under the License.
18;;
19;; %CopyrightEnd%
20
21;;; Commentary:
22
23;; Crawl Erlang/OTP HTML documentation and generate lookup tables.
24;;
25;; This package depends on `cl-lib', `pcase' and
26;; `libxml-parse-html-region'.  Emacs 24+ compiled with libxml2 should
27;; work.  On Emacs 24.1 and 24.2 do `M-x package-install RET cl-lib
28;; RET' to install `cl-lib'.
29;;
30;; Please customise `erldoc-man-index' to point to your local OTP
31;; documentation.
32;;
33;; To use:
34;;
35;;   (define-key help-map "u" 'erldoc-browse)
36;;   (define-key help-map "t" 'erldoc-browse-topic)
37;;   (define-key help-map "a" 'erldoc-apropos)
38;;
39;; Note: these commands trigger indexing OTP documentation on first
40;; run with cache to disk which may take 1-2 minutes.
41
42
43;;; Examples:
44
45;; 1. `M-x erldoc-browse RET erlang:integer_to_binary/2 RET' opens the
46;;    `erlang' manual anchored on the entry for `integer_to_binary/2'.
47;;
48;; 2. `M-x erldoc-apropos RET first RET' list all MFAs matching
49;;    substring `first'.
50;;
51;; 3. `M-x erldoc-browse-topic RET efficiency_guide#Introduction RET'
52;;    opens chapter `Introduction' of the `Efficiency Guide' in the
53;;    browser.
54
55;;; History:
56
57;; Written in December 2013 as a temporary solution to help me browse
58;; the rich Erlang/OTP documentation. Three years on I find myself
59;; still using it every day.  - Leo (2016)
60
61;;; Code:
62
63(require 'cl-lib)
64(require 'json)
65(require 'erlang)
66(eval-when-compile (require 'url-parse))
67
68(eval-and-compile                       ;for emacs < 24.3
69  (or (fboundp 'user-error) (defalias 'user-error 'error)))
70
71(defgroup erldoc nil
72  "Browse Erlang document."
73  :group 'help)
74
75(defcustom erldoc-man-index "http://www.erlang.org/doc/man_index.html"
76  "The URL to the man_index.html page.
77Note it is advisable to customise this to a local URL for example
78`file:///usr/local/19.1/lib/erlang/doc/man_index.html' to speed
79up the indexing."
80  :type 'string
81  :group 'erldoc)
82
83(defcustom erldoc-verify-man-path nil
84  "If non-nil verify man path existence for `file://'."
85  :type 'boolean
86  :group 'erldoc)
87
88(defcustom erldoc-output-file (locate-user-emacs-file "cache/erldoc")
89  "File to store the parsed results."
90  :type 'file
91  :group 'erldoc)
92
93(defcustom erldoc-no-signature-function #'ignore
94  "Notification function called if no function signature was found."
95  :type '(choice (function-item :tag "Ignore" ignore)
96                 (function-item :tag "Warn" warn)
97                 (function-item :tag "Error" error))
98  :group 'erldoc)
99
100(defun erldoc-strip-string (s)
101  (let* ((re "[ \t\n\r\f\v\u00a0]+")
102         (from (if (string-match (concat "\\`" re) s) (match-end 0) 0))
103         (to (and (string-match (concat re "\\'") s) (match-beginning 0))))
104    (substring s from (and to (max to from)))))
105
106;; Note: don't know how to get the BASE-URL to
107;; `libxml-parse-html-region' to work.
108(defun erldoc-expand-url (url base-url)
109  (if (url-type (url-generic-parse-url url))
110      url
111    (let* ((base (url-generic-parse-url base-url))
112           (dir (directory-file-name (file-name-directory (url-filename base)))))
113      (setf (url-filename base) (expand-file-name url dir))
114      (url-recreate-url base))))
115
116(defun erldoc-parse-html (url)
117  (with-temp-buffer
118    (url-insert-file-contents url)
119    (libxml-parse-html-region (point-min) (point-max))))
120
121(defalias 'erldoc-dom-text-node-p #'stringp)
122
123(defun erldoc-dom-attributes (dom)
124  (and (not (erldoc-dom-text-node-p dom)) (cadr dom)))
125
126(defun erldoc-dom-get-attribute (dom attrib-name)
127  (cdr (assq attrib-name (erldoc-dom-attributes dom))))
128
129(defun erldoc-dom-children (dom)
130  (and (not (erldoc-dom-text-node-p dom)) (cddr dom)))
131
132(defun erldoc-dom-get-text (dom)
133  (let ((text (car (last (erldoc-dom-children dom)))))
134    (and (erldoc-dom-text-node-p text) text)))
135
136(defvar erldoc-dom-walk-parent nil)
137(defvar erldoc-dom-walk-siblings nil)
138
139(defun erldoc-dom-walk (dom k)
140  (funcall k dom)
141  (let ((erldoc-dom-walk-parent dom)
142        (erldoc-dom-walk-siblings (unless (erldoc-dom-text-node-p dom)
143                                    (cddr dom))))
144    (dolist (child erldoc-dom-walk-siblings)
145      (erldoc-dom-walk child k))))
146
147(defun erldoc-dom-get-element (dom element-name)
148  (catch 'return
149    (erldoc-dom-walk dom (lambda (d)
150                           (when (eq (car-safe d) element-name)
151                             (throw 'return d))))))
152
153(defun erldoc-dom-get-element-by-id (dom id)
154  (catch 'return
155    (erldoc-dom-walk dom (lambda (d)
156                           (when (equal (erldoc-dom-get-attribute d 'id) id)
157                             (throw 'return d))))))
158
159(defun erldoc-dom-get-elements-by-id (dom id)
160  (let (result)
161    (erldoc-dom-walk dom (lambda (d)
162                           (when (equal (erldoc-dom-get-attribute d 'id) id)
163                             (push d result))))
164    (nreverse result)))
165
166(defun erldoc-fix-path (url)
167  (if (and erldoc-verify-man-path
168           ;; Could only verify local files
169           (equal (url-type (url-generic-parse-url url)) "file"))
170      (let* ((obj (url-generic-parse-url url))
171             (new (car (file-expand-wildcards
172                        (replace-regexp-in-string
173                         "-[0-9]+\\(?:[.][0-9]+\\)*" "*"
174                         (url-filename obj))))))
175        (or new (error "File %s does not exist" (url-filename obj)))
176        (setf (url-filename obj) new)
177        (url-recreate-url obj))
178    url))
179
180(defun erldoc-parse-man-index (url)
181  (let ((table (erldoc-dom-get-element (erldoc-parse-html url) 'table))
182        (mans))
183    (erldoc-dom-walk
184     table
185     (lambda (d)
186       (when (eq (car-safe d) 'a)
187         (let ((href (erldoc-dom-get-attribute d 'href)))
188           (when (and href (not (string-match-p "index\\.html\\'" href)))
189             (with-demoted-errors "erldoc-parse-man-index: %S"
190               (push (cons (erldoc-dom-get-text d)
191                           (erldoc-fix-path (erldoc-expand-url href url)))
192                     mans)))))))
193    (nreverse mans)))
194
195(defun erldoc-parse-man (man)
196  (let ((dom (erldoc-parse-html (cdr man)))
197        (table (make-hash-table :test #'equal)))
198    (erldoc-dom-walk
199     (erldoc-dom-get-element-by-id dom "loadscrollpos")
200     (lambda (d)
201       (let ((href (erldoc-dom-get-attribute d 'href)))
202         (when (and href (string-match "#" href))
203           (puthash (substring href (match-end 0))
204                    (list (concat (car man) ":" (erldoc-strip-string
205                                                 (erldoc-dom-get-text d)))
206                          (erldoc-expand-url href (cdr man)))
207                    table)))))
208    (let ((span-content
209           (lambda (span)
210             (let ((texts))
211               (erldoc-dom-walk span
212                                (lambda (d)
213                                  (and (erldoc-dom-text-node-p d)
214                                       (push (erldoc-strip-string d) texts))))
215               (and texts (mapconcat 'identity (nreverse texts) " ")))))
216          entries)
217      (erldoc-dom-walk
218       dom
219       (lambda (d)
220         ;; Get the full function signature.
221         (when (and (eq (car-safe d) 'a)
222                    (gethash (erldoc-dom-get-attribute d 'name) table))
223           (let* ((name (erldoc-dom-get-attribute d 'name))
224                  (mfa-url (gethash name table))
225                  (mfa (car mfa-url))
226                  (sig (or (funcall span-content d)
227                           (funcall span-content
228                                    (or (erldoc-dom-get-element d 'span)
229                                        (cadr
230                                         (memq d erldoc-dom-walk-siblings))))
231                           (progn
232                             (funcall erldoc-no-signature-function
233                                      "erldoc-parse-man: no sig for %s"
234                                      mfa)
235                             nil))))
236             (push (append mfa-url (list sig))
237                   entries)))
238         ;; Get data types
239         (when (and (eq (car-safe d) 'a)
240                    (string-prefix-p "type-"
241                                     (or (erldoc-dom-get-attribute d 'name) "")))
242           (push (list (concat (car man) ":" (funcall span-content d))
243                       (concat (cdr man) "#" (erldoc-dom-get-attribute d 'name))
244                       (funcall span-content erldoc-dom-walk-parent))
245                 entries))))
246      entries)))
247
248(defun erldoc-parse-all (man-index output &optional json)
249  (let* ((output (expand-file-name output))
250         (table (make-hash-table :size 11503 :test #'equal))
251         (mans (erldoc-parse-man-index man-index))
252         (progress 1)
253         (reporter (make-progress-reporter "Parsing Erlang/OTP documentation"
254                                           progress (length mans)))
255         fails all)
256    (dolist (man mans)
257      (condition-case err
258          (push (erldoc-parse-man man) all)
259        (error (push (error-message-string err) fails)))
260      (accept-process-output nil 0.01)
261      (progress-reporter-update reporter (cl-incf progress)))
262    (when fails
263      (display-warning 'erldoc-parse-all
264                       (format "\n\n%s" (mapconcat #'identity fails "\n"))
265                       :error))
266    (progress-reporter-done reporter)
267    (mapc (lambda (x) (puthash (car x) (cdr x) table))
268          (apply #'nconc (nreverse all)))
269    (with-temp-buffer
270      (if (not json)
271          (pp table (current-buffer))
272        (let ((json-encoding-pretty-print t))
273          (insert (json-encode table))))
274      (unless (file-directory-p (file-name-directory output))
275        (make-directory (file-name-directory output) t))
276      (write-region nil nil output nil nil nil 'ask))))
277
278(defun erldoc-otp-release ()
279  "Get the otp release version (as string) or nil if not found."
280  (let ((otp (erldoc-dom-get-text
281              (erldoc-dom-get-element
282               (erldoc-parse-html
283                (erldoc-expand-url "index.html" erldoc-man-index))
284               'title))))
285    (and (string-match "[0-9.]+\\'" otp) (match-string 0 otp))))
286
287(defvar erldoc-browse-history nil)
288(defvar erldoc-lookup-table nil)
289
290(defun erldoc-lookup-table ()
291  (or erldoc-lookup-table
292      (progn
293        (unless (file-exists-p erldoc-output-file)
294          (let ((of (pcase (erldoc-otp-release)
295                      (`nil erldoc-output-file)
296                      (ver (concat erldoc-output-file "-" ver)))))
297            (unless (file-exists-p of)
298              (erldoc-parse-all erldoc-man-index of))
299            (unless (string= erldoc-output-file of)
300              (make-symbolic-link (expand-file-name of) erldoc-output-file))))
301        (setq erldoc-lookup-table
302              (with-temp-buffer
303                (insert-file-contents erldoc-output-file)
304                (read (current-buffer)))))))
305
306(defun erldoc-best-matches (mfa)
307  (pcase mfa
308    ((and `(,m ,f) (let a (erlang-get-function-arity)))
309     (let ((mfa (format "%s:%s/%s" m f a)))
310       (cond ((gethash mfa (erldoc-lookup-table)) (list mfa))
311             (m (all-completions (concat m ":" f "/") (erldoc-lookup-table)))
312             (t (let* ((mod (erlang-get-module))
313                       (mf1 (and mod (concat mod ":" f "/")))
314                       (mf2 (concat "erlang:" f "/"))
315                       (re (concat ":" (regexp-quote f) "/")))
316                  (or (and mf1 (all-completions mf1 (erldoc-lookup-table)))
317                      (all-completions mf2 (erldoc-lookup-table))
318                      (cl-loop for k being the hash-keys of (erldoc-lookup-table)
319                               when (string-match-p re k)
320                               collect k)))))))))
321
322;;;###autoload
323(defun erldoc-browse (mfa)
324  (interactive
325   (let ((default
326           ;; `erlang-mode-syntax-table' is lazily initialised.
327           (with-syntax-table (or erlang-mode-syntax-table (standard-syntax-table))
328             (ignore-errors
329               (erldoc-best-matches
330                (or (erlang-get-function-under-point)
331                    (save-excursion
332                      (goto-char (or (cadr (syntax-ppss)) (point)))
333                      (erlang-get-function-under-point))))))))
334     (list (completing-read (format (if default "Function {%d %s} (default %s): "
335                                      "Function: ")
336                                    (length default)
337                                    (if (= (length default) 1) "guess" "guesses")
338                                    (car default))
339                            (erldoc-lookup-table)
340                            nil t nil 'erldoc-browse-history default))))
341  (or (stringp mfa)
342      (signal 'wrong-type-argument (list 'string mfa 'mfa)))
343  (browse-url (or (car (gethash mfa (erldoc-lookup-table)))
344                  (user-error "No documentation for %s" mfa))))
345
346;;;###autoload
347(defun erldoc-apropos (pattern)
348  (interactive "sPattern: ")
349  (with-help-window (help-buffer)
350    (with-current-buffer standard-output
351      (princ (concat "Erldoc apropos pattern: " pattern "\n\n"))
352      (maphash (lambda (k v)
353                 (when (string-match-p pattern k)
354                   (insert-text-button k :type 'help-url
355                                       'help-args (list (car v)))
356                   (insert "\n")))
357               (erldoc-lookup-table)))))
358
359(defun erldoc-tokenize-signature (sig)
360  ;; Divide SIG into (MF ARGLIST RETTYPE)
361  (let ((from (if (string-match "\\`.+?(" sig)
362                  (1- (match-end 0))
363                0))
364        (to (and (string-match "\\s-*->\\s-*.*?\\'" sig) (match-beginning 0))))
365    (list (erldoc-strip-string (substring sig 0 from))
366          (erldoc-strip-string (substring sig from (and to (max from to))))
367          (and to (erldoc-strip-string (substring sig to))))))
368
369(defun erldoc-format-signature (mod fn)
370  (when (and mod fn (or erldoc-lookup-table
371                        (file-exists-p erldoc-output-file)))
372    (let ((re (concat "\\`" mod ":" fn "/\\([0-9]+\\)\\'"))
373          (sigs))
374      (maphash (lambda (k v)
375                 (when (string-match re k)
376                   (if (cadr v)
377                       (push (cons (string-to-number (match-string 1 k))
378                                   (cdr (erldoc-tokenize-signature (cadr v))))
379                             sigs)
380                     (funcall erldoc-no-signature-function
381                              "erldoc-format-signature: No sig for %s" k))))
382               (erldoc-lookup-table))
383      (when sigs
384        ;; Mostly single return type but there are exceptions such as
385        ;; `beam_lib:chunks/2,3'.
386        (let ((single-rettype
387               (cl-reduce (lambda (x1 x2) (and x1 x2 (equal x1 x2) x1))
388                          sigs :key #'cl-caddr))
389              (sigs (sort sigs #'car-less-than-car)))
390          (if single-rettype
391              (concat mod ":" fn (mapconcat #'cadr sigs " | ") " " single-rettype)
392            (mapconcat (lambda (x) (concat mod ":" fn (nth 1 x) " " (nth 2 x)))
393                       sigs "\n")))))))
394
395;;;###autoload
396(defun erldoc-eldoc-function ()
397  "A function suitable for `eldoc-documentation-function'."
398  (save-excursion
399    (pcase (erlang-get-function-under-point)
400      (`(,_ nil) )
401      (`(nil ,fn)  (erldoc-format-signature "erlang" fn))
402      (`(,mod ,fn) (erldoc-format-signature mod fn)))))
403
404(defun erldoc-parse-eeps-index ()
405  (let* ((url "http://www.erlang.org/eeps/")
406         (table (catch 'return
407                  (erldoc-dom-walk (erldoc-parse-html url)
408                                   (lambda (d)
409                                     (and (eq (car-safe d) 'table)
410                                          (equal (erldoc-dom-get-attribute d 'summary)
411                                                 "Numerical Index of EEPs")
412                                          (throw 'return d))))))
413         (fix-title (lambda (title)
414                      (replace-regexp-in-string
415                       "`` *" "" (replace-regexp-in-string " *``, *" " by " title))))
416         (result))
417    (erldoc-dom-walk
418     table (lambda (d)
419             (when (eq (car-safe d) 'a)
420               (push (cons (funcall fix-title (erldoc-dom-get-attribute d 'title))
421                           (erldoc-expand-url
422                            (erldoc-dom-get-attribute d 'href)
423                            url))
424                     result))))
425    (nreverse result)))
426
427(defvar erldoc-user-guides nil)
428
429(defvar erldoc-missing-user-guides
430  '("compiler" "hipe" "kernel" "os_mon" "parsetools")
431  "List of standard Erlang applications with no user guides.")
432
433;; Search in `code:lib_dir/0' using find LIB_DIR -type f -name
434;; '*_app.html'.
435(defvar erldoc-app-manuals '("crypto" "diameter" "erl_docgen"
436                             "kernel" "observer" "os_mon"
437                             "runtime_tools" "sasl" "snmp"
438                             "ssl" "test_server"
439                             ("ssh" . "SSH") ("stdlib" . "STDLIB")
440                             ("hipe" . "HiPE"))
441  "List of applications that come with a manual.")
442
443(defun erldoc-user-guide-chapters (user-guide)
444  (pcase-let ((`(,name . ,url) user-guide))
445    (unless (member name erldoc-missing-user-guides)
446      (let ((chaps (erldoc-dom-get-elements-by-id
447                    (erldoc-dom-get-element-by-id (erldoc-parse-html url) "leftnav")
448                    "no")))
449        (or chaps (warn "erldoc-user-guide-chapters no chapters found for `%s'"
450                        (cdr user-guide)))
451        (mapcar (lambda (li)
452                  (cons (concat name "#" (erldoc-dom-get-attribute li 'title))
453                        (erldoc-expand-url (erldoc-dom-get-attribute
454                                            (erldoc-dom-get-element li 'a) 'href)
455                                           url)))
456                chaps)))))
457
458(defun erldoc-user-guides-1 ()
459  (let ((url (erldoc-expand-url "applications.html" erldoc-man-index))
460        app-guides app-mans)
461    (erldoc-dom-walk
462     (erldoc-parse-html url)
463     (lambda (d)
464       (when (and (eq (car-safe d) 'a)
465                  (not (string-match-p "\\`[0-9.]+\\'" (erldoc-dom-get-text d))))
466         (with-demoted-errors "erldoc-user-guides-1: %S"
467           (let ((name (erldoc-strip-string (erldoc-dom-get-text d)))
468                 (index-page (erldoc-fix-path (erldoc-expand-url
469                                               (erldoc-dom-get-attribute d 'href) url))))
470             (push (cons name (if (member name erldoc-missing-user-guides)
471                                  index-page
472                                (erldoc-expand-url "users_guide.html" index-page)))
473                   app-guides)
474             ;; Collect application manuals.
475             (pcase (assoc name (mapcar (lambda (x) (if (consp x) x (cons x x)))
476                                        erldoc-app-manuals))
477               (`(,_ . ,manual)
478                (push (cons name
479                            (erldoc-expand-url (format "%s_app.html" manual)
480                                               index-page))
481                      app-mans))))))))
482    (list (nreverse app-guides)
483          (nreverse app-mans))))
484
485(defun erldoc-user-guides ()
486  (or erldoc-user-guides
487      (let ((file (concat erldoc-output-file "-topics")))
488        (unless (file-exists-p file)
489          (unless (file-directory-p (file-name-directory file))
490            (make-directory (file-name-directory file) t))
491          (with-temp-buffer
492            (pcase-let ((`(,guides ,mans) (erldoc-user-guides-1)))
493              (pp (append (cl-mapcan #'erldoc-user-guide-chapters
494                                     (append (mapcar
495                                              (lambda (dir)
496                                                (cons dir (erldoc-expand-url
497                                                           (concat dir "/users_guide.html")
498                                                           erldoc-man-index)))
499                                              '("design_principles"
500                                                "efficiency_guide"
501                                                "embedded"
502                                                "getting_started"
503                                                "installation_guide"
504                                                "oam"
505                                                "programming_examples"
506                                                "reference_manual"
507                                                "system_architecture_intro"
508                                                "system_principles"
509                                                "tutorial"))
510                                             guides))
511                          (mapcar (lambda (man)
512                                    (pcase-let ((`(,name . ,url) man))
513                                      (cons (concat name " (App)") url)))
514                                  mans)
515                          (erldoc-parse-eeps-index))
516                  (current-buffer)))
517            (write-region nil nil file nil nil nil 'ask)))
518        (setq erldoc-user-guides (with-temp-buffer (insert-file-contents file)
519                                                   (read (current-buffer)))))))
520
521;;;###autoload
522(defun erldoc-browse-topic (topic)
523  (interactive
524   (list (completing-read "User guide: " (erldoc-user-guides) nil t)))
525  (browse-url (cdr (assoc topic (erldoc-user-guides)))))
526
527(provide 'erldoc)
528
529;; Local variables:
530;; coding: utf-8
531;; indent-tabs-mode: nil
532;; End:
533
534;;; erldoc.el ends here
535