--- /dev/null
+;;; dict.el --- Get word definitions from RFC2229 dictionary servers -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Eshel Yaron
+
+;; Author: Eshel Yaron <me@eshelyaron.com>
+;; Keywords: help, comm
+;; URL: https://git.eshelyaron.com/gitweb/dict.git
+;; Package-Version: 0.1.0
+;; Package-Requires: ((emacs "29.1"))
+
+;; 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 this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Dict defines a single command that displays the definition of a
+;; given word, as obtained from an RFC2229 dictionary server. To use
+;; it, invoke \\[dict-describe-word].
+
+;;; Code:
+
+(defgroup dict nil
+ "Access to RFC2229 dictionary servers."
+ :group 'help)
+
+(defcustom dict-process-buffer-name "*dict output*"
+ "Buffer name for dictionary server output."
+ :type 'string)
+
+(defcustom dict-process-name "dict"
+ "Process name for dictionary server connection."
+ :type 'string)
+
+(defcustom dict-server-host "dict.org"
+ "Host or IP address of dictionary server."
+ :type 'string)
+
+(defcustom dict-server-port 2628
+ "Port of dictionary server."
+ :type 'natnum)
+
+(defcustom dict-dictionary nil
+ "Name of the dictionary to use for matching and defining words."
+ :type '(choice (const :tag "Prompt on first use" nil)
+ (string :tag "Select dictionary")))
+
+(defcustom dict-strategy nil
+ "Name of the dictionary matching strategy to use."
+ :type '(choice (const :tag "Prompt on first use" nil)
+ (string :tag "Select strategy")))
+
+(defcustom dict-display-definition-function
+ #'dict-display-definition-in-help-buffer
+ "Function to use for displaying dictionary definitions."
+ :type 'function)
+
+(defvar dict-process nil)
+
+(defvar dict-read-word-history nil)
+
+(defvar dict-match-cache nil)
+
+(defun dict-command (command parse)
+ "Invoke a dictionary server command.
+COMMAND is an RFC2229 command in string format, without a newline.
+
+Return the result of calling the function PARSE in a the
+beginning of a buffer with the server's response."
+ (let ((buffer (get-buffer-create dict-process-buffer-name)))
+ (with-current-buffer buffer
+ (delete-region (point-min) (point-max)))
+ (let* ((result nil)
+ (done nil)
+ (filter
+ (lambda (process string)
+ (internal-default-process-filter process string)
+ (with-current-buffer (process-buffer process)
+ (save-excursion
+ (goto-char (point-min))
+ (cond
+ ((search-forward "\r\n5" nil t) ; error code
+ (setq done t))
+ ((search-forward "\r\n.\r\n" nil t)
+ (goto-char (point-min))
+ (setq result (funcall parse)
+ done t)))))))
+ (proc (if (process-live-p dict-process)
+ dict-process
+ (setq dict-process
+ (make-network-process
+ :name dict-process-name
+ :host dict-server-host
+ :service dict-server-port
+ :buffer buffer)))))
+ (set-process-filter proc filter)
+ (process-send-string proc (concat command "\n"))
+ (while (not done)
+ (accept-process-output proc 1))
+ result)))
+
+(defun dict-match-word (word)
+ "Return dictionary matches for WORD as a list of strings."
+ (unless (string-empty-p word)
+ (if (string= (car dict-match-cache) word)
+ (cdr dict-match-cache)
+ (setq dict-match-cache
+ (cons word
+ (dict-command
+ (format "match %s %s \"%s\""
+ (dict-dictionary)
+ (dict-strategy)
+ word)
+ (lambda ()
+ (let ((result nil))
+ (search-forward "\r\n152" nil t)
+ (while (not (looking-at (rx "\r\n.\r\n")))
+ (search-forward "\r\n" nil t)
+ (search-forward " " nil t)
+ (push (read (current-buffer)) result))
+ (reverse result)))))))))
+
+(defun dict-define-word (word)
+ "Return the dictionary definition of WORD, or nil if not defined."
+ (dict-command (format "define %s \"%s\""
+ (dict-dictionary)
+ word)
+ (lambda ()
+ (search-forward "\r\n151" nil t)
+ (buffer-substring
+ (search-forward "\r\n")
+ (- (search-forward "\r\n.\r\n" nil t) 5)))))
+
+(defun dict-get-strategies ()
+ "Return the dictionary server's supported matching strategies."
+ (cons
+ '("." . "Default strategy")
+ (dict-command "show strat"
+ (lambda ()
+ (let ((result nil))
+ (search-forward "\r\n111" nil t)
+ (while (not (looking-at (rx "\r\n.\r\n")))
+ (push (cons (buffer-substring
+ (search-forward "\r\n" nil t)
+ (1- (search-forward " " nil t)))
+ (read (current-buffer)))
+ result))
+ result)))))
+
+(defun dict-read-strategy ()
+ "Prompt for a matching strategy supported by the dictionary server."
+ (let* ((strats (dict-get-strategies))
+ (len (apply #'max (mapcar #'length (mapcar #'car strats))))
+ (completion-extra-properties
+ (list :annotation-function
+ (lambda (key)
+ (concat (make-string (1+ (- len (length key))) ?\s)
+ (alist-get key strats nil nil #'string=))))))
+ (completing-read "Strategy: "
+ strats nil t)))
+
+(defun dict-strategy ()
+ "Return the value of the user option `dict-strategy'.
+If its nil, prompt for a supported strategy and set the user
+option to it first."
+ (or dict-strategy
+ (setq dict-strategy (dict-read-strategy))))
+
+(defun dict-get-dictionaries ()
+ "Return the dictionary server's supported dictionaries."
+ (append
+ '(("*" . "All dictionaries")
+ ("!" . "First matching dictionary"))
+ (dict-command "show db"
+ (lambda ()
+ (let ((result nil))
+ (search-forward "\r\n110" nil t)
+ (while (not (looking-at (rx "\r\n.\r\n")))
+ (push (cons (buffer-substring
+ (search-forward "\r\n" nil t)
+ (1- (search-forward " " nil t)))
+ (read (current-buffer)))
+ result))
+ result)))))
+
+(defun dict-read-dictionary ()
+ "Prompt for dictionary server's supported by the dictionary server."
+ (let* ((dicts (dict-get-dictionaries))
+ (len (apply #'max (mapcar #'length (mapcar #'car dicts))))
+ (completion-extra-properties
+ (list :annotation-function
+ (lambda (key)
+ (concat (make-string (1+ (- len (length key))) ?\s)
+ (alist-get key dicts nil nil #'string=))))))
+ (completing-read "Dictionary: "
+ dicts nil t)))
+
+(defun dict-dictionary ()
+ "Return the value of the user option `dict-dictionary'.
+If its nil, prompt for a supported dictionary and set the user
+option to it first."
+ (or dict-dictionary
+ (setq dict-dictionary (dict-read-dictionary))))
+
+(defun dict-read-word ()
+ "Prompt for a word known to the dictionary server."
+ (let* ((completion-ignore-case t)
+ (word-at-point (thing-at-point 'word t))
+ (default (car (dict-match-word word-at-point))))
+ (completing-read (format-prompt "Word" default)
+ (completion-table-dynamic #'dict-match-word)
+ nil t nil 'dict-read-word-history default t)))
+
+(define-button-type 'help-word
+ :supertype 'help-xref
+ 'help-function 'dict-describe-word
+ 'help-echo (purecopy "mouse-2, RET: describe this word"))
+
+(defun dict-display-definition-in-help-buffer (word definition)
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'dict-describe-word word)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert (string-replace "\r\n" "\n" definition))
+ (goto-char (point-min))
+ (while (re-search-forward (rx "{"
+ (group-n 1 (* (not (any ?}))))
+ "}")
+ nil t)
+ (help-xref-button 1 'help-word (match-string 1)))))))
+
+;;;###autoload
+(defun dict-describe-word (word)
+ "Display the definition of WORD.
+
+This command obtains the definition of WORD from the RFC2229
+dictionary server specified by `dict-server-host' and
+`dict-server-port'. When successful, it calls the function
+specified by `dict-display-definition-function' to display the
+definition. (By default, this uses a *Help* buffer.)"
+ (interactive (list (dict-read-word)))
+ (let ((definition (dict-define-word word)))
+ (if definition
+ (funcall dict-display-definition-function word definition)
+ (user-error "No definition found for \"%s\"" word))))
+
+(provide 'dict)
+;;; dict.el ends here
projects / dict.git / commitdiff