[nongnu] elpa/forth-mode 1d85344467 113/153: Add commands to browse description in Forth standards

[ELPA Syncer]

branch: elpa/forth-mode
commit 1d853444671de2b88e129ab7c14632599a1cfc4c
Author: Helmut Eller <eller.helmut@gmail.com>
Commit: Lars Brinkhoff <lars@nocrew.org>

    Add commands to browse description in Forth standards
    
    The keys C-c C-d 1 resp. C-c C-d 2 invoke the command to lookup
    a word in the '94 resp. 2012 version of the standard.
    
    * forth-spec.el: New file.
    * forth-mode.el: Load it and bind keys.
    * test/tests.el: Add tests.
---
 forth-mode.el |   3 ++
 forth-spec.el | 171 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 test/tests.el |   8 +++
 3 files changed, 182 insertions(+)

diff --git a/forth-mode.el b/forth-mode.el
index e1c103d0d2..deff50e903 100644
--- a/forth-mode.el
+++ b/forth-mode.el
@@ -15,6 +15,7 @@
 (require 'cl)
 (require 'forth-syntax)
 (require 'forth-smie)
+(require 'forth-spec)
 
 (defvar forth-mode-map
   (let ((map (make-sparse-keymap)))
@@ -27,6 +28,8 @@
     (define-key map (kbd "C-x M-e") 'forth-eval-last-expression-display-output)
     (define-key map (kbd "C-c C-z") 'forth-switch-to-output-buffer)
     (define-key map (kbd "C-c :") 'forth-eval)
+    (define-key map (kbd "C-c C-d 1") 'forth-spec-lookup-1994)
+    (define-key map (kbd "C-c C-d 2") 'forth-spec-lookup-2012)
     ;; (define-key map (kbd "C-c C-c") 'eval-buffer)
     ;; (define-key map (kbd "C-x `") #'forth-next-error)
     ;; (define-key map (kbd "M-n") #'forth-next-note)
diff --git a/forth-spec.el b/forth-spec.el
new file mode 100644
index 0000000000..3f3ca22a2b
--- /dev/null
+++ b/forth-spec.el
@@ -0,0 +1,171 @@
+;;; forth-spec.el --- Browse words in Forth standard   -*-lexical-binding:t-*-
+;;
+;; Copyright (C) 2016  Helmut Eller <eller.helmut@gmail.com>
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This package makes it convenient to browse documentation for
+;; standard Forth words from within Emacs.  The command
+;; `forth-spec-lookup' asks for the word name and invokes the HTML
+;; browser with the right URL.
+
+;;; Code:
+
+(eval-and-compile
+  (or (require 'cl-lib nil t)
+      ;; Emacs 23
+      (progn
+       (require 'cl)
+       (defmacro cl-ecase (&rest x) `(ecase . ,x)))))
+
+(defgroup forth-spec
+  nil
+  "Browsing Forth standards."
+  :group 'forth)
+
+(defcustom forth-spec-url-2012 "http://www.forth200x.org/documents/html/";
+  "The URL which contains the HTML version of the standard.
+If you have a local copy set this variable to
+something like \"file://home/joe/docs/ANS-Forth/\".
+
+Note: the string should have a trailing backslash."
+  :type 'file
+  :group 'forth-spec)
+
+(defcustom forth-spec-url-1994 "http://lars.nocrew.org/dpans/";
+  "URL for 1994 version of standard."
+  :type 'file
+  :group 'forth-spec)
+
+(defcustom forth-spec-browse-url #'browse-url
+  "Just in case you want to use a special browser."
+  :type 'function
+  :group 'forth-spec)
+
+(defun forth-spec-lookup-2012 (name)
+  "View the documentation on NAME from the Forth 2012 Standard."
+  (interactive (list (forth-spec--read-name 2012)))
+  (forth-spec--lookup name 2012))
+
+(defun forth-spec-lookup-1994 (name)
+  "View the documentation on NAME from the ANS'94 Forth Standard."
+  (interactive (list (forth-spec--read-name 1994)))
+  (forth-spec--lookup name 1994))
+
+(defun forth-spec--lookup (name version)
+  (funcall forth-spec-browse-url (forth-spec--build-url name version)))
+
+(defvar forth-spec--lookup-history '())
+
+(defun forth-spec--read-name (version)
+  "Read a word-name in the minibuffer, with completion."
+  (let ((completion-ignore-case t))
+    (completing-read "Word: " (forth-spec--index version)
+                    nil t (thing-at-point 'symbol)
+                    'forth-spec--lookup-history)))
+(eval-and-compile
+  (defvar forth-spec--versioned-info
+    '((2012 forth-spec-url-2012 "alpha.html" #'forth-spec--parse-2012)
+      (1994 forth-spec-url-1994 "dpansf.htm" #'forth-spec--parse-1994))))
+
+(defmacro forth-spec--versioned (name version)
+  (let ((index (cl-ecase name
+                (url 1)
+                (index 2)
+                (parse-index 3))))
+    `(cl-ecase ,version
+       (2012 ,(elt (assoc 2012 forth-spec--versioned-info) index))
+       (1994 ,(elt (assoc 1994 forth-spec--versioned-info) index)))))
+
+(defun forth-spec--root (version)
+  (forth-spec--versioned url version))
+
+(defun forth-spec--build-url (name version)
+  "Return the URL for the word NAME."
+  (concat (forth-spec--root version)
+         (elt (or (assoc name (forth-spec--index version))
+                  (error "Name not found in index: %s" name))
+              1)))
+
+(defvar forth-spec--index-cache nil)
+
+(defun forth-spec--index (version)
+  "Return a list ((NAME HREF PRONUNCIATION) ...)."
+  (let ((entry (assoc version forth-spec--index-cache)))
+    (cond (entry (cdr entry))
+         (t
+          (let ((index (forth-spec--parse-index version)))
+            (push (cons version index) forth-spec--index-cache)
+            index)))))
+
+(defun forth-spec--index-url (version)
+  (concat (forth-spec--root version) (forth-spec--versioned index version)))
+
+(defun forth-spec--parse-index (version)
+  (forth-spec--call/url-buffer (forth-spec--index-url version)
+                         (forth-spec--versioned parse-index version)))
+
+(defun forth-spec--call/url-buffer (url fun)
+  (let ((buffer (url-retrieve-synchronously url)))
+    (unwind-protect
+       (with-current-buffer buffer
+         (funcall fun))
+      (kill-buffer buffer))))
+
+(defun forth-spec--parse-2012 ()
+  (let ((index '())
+       (case-fold-search nil)
+       (rx "<td>\
+<a href=\"\\([^\"]+\\)\">\\([^<]+\\)</a>\
+</td><td>\\(?:\"\\([^\"]+\\)\"\\)?</td>"))
+    (search-forward "<table")
+    (while (re-search-forward rx nil t)
+      (push (list (forth-spec--decode-entities (match-string 2))
+                 (match-string 1)
+                 (match-string 3))
+           index))
+    (reverse index)))
+
+;; (forth-spec--parse-index 1994)
+(defun forth-spec--parse-1994 ()
+  (let ((index '())
+       (case-fold-search nil)
+       (rx "<A href=\\(dpans[^>]+\\)>[^<]+</A>[ ]*\\([^ ]+\\)[ ]*\
+\\(?:<B>\\([^\<]+\\)</B>\\)?"))
+    (search-forward "<PRE>")
+    (while (re-search-forward rx nil t)
+      (push (list (forth-spec--decode-entities (match-string 2))
+                 (match-string 1)
+                 (match-string 3))
+           index))
+    (reverse index)))
+
+(declare-function mm-url-decode-entities "gnus/mm-url")
+(autoload 'mm-url-decode-entities "gnus/mm-url")
+;; For annoying reasons, we need to declare this here.
+(autoload 'mm-disable-multibyte "gnus/mm-util")
+
+(defun forth-spec--decode-entities (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (save-match-data
+      (mm-url-decode-entities))
+    (buffer-string)))
+
+(provide 'forth-spec)
+
+;;; forth-spec.el ends here
diff --git a/test/tests.el b/test/tests.el
index 75ab802ec1..1bf7e55805 100644
--- a/test/tests.el
+++ b/test/tests.el
@@ -203,3 +203,11 @@ The whitespace before and including \"|\" on each line is 
removed."
   (forth-assert-forward-word "include /tmp/foo.fth \ bar" 1 8)
   (forth-assert-forward-word "include /tmp/foo.fth \ bar" 8 13)
   (forth-assert-forward-word "foo-bar" 1 4))
+
+(ert-deftest forth-spec-parsing ()
+  (should (equal (forth-spec--build-url "SWAP" 1994)
+                "http://lars.nocrew.org/dpans/dpans6.htm#6.1.2260";))
+  (should
+   (equal (forth-spec--build-url "SWAP" 2012)
+         "http://www.forth200x.org/documents/html/core.html#core:SWAP";)))
+