From 749743aa703a98352cb12ad84c04c971b22ea44c Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Mon, 15 May 2023 21:04:21 +0300 Subject: [PATCH v4] Add customization options for dictionary-search Allow users to customize 'dictionary-search' via several new customization options. * lisp/net/dictionary.el (dictionary-define-word) (dictionary-match-word, dictionary-completing-read-word) (dictionary-dictionaries, dictionary-completing-read-dictionary) (dictionary-display-definition-in-help-buffer): New functions. (dictionary-read-word-prompt) (dictionary-display-definition-function) (dictionary-read-word-function) (dictionary-read-dictionary-function) (dictionary-search-interface): New user options. (dictionary-search): Use them. (dictionary-read-dictionary-default) (dictionary-read-word-default): New functions, extracted from 'dictionary-search'. * etc/NEWS: Announce. --- etc/NEWS | 45 +++++++++ lisp/net/dictionary.el | 203 ++++++++++++++++++++++++++++++++++++++--- 2 files changed, 233 insertions(+), 15 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 7729dbc79fa..07fc2fab774 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -342,6 +342,51 @@ The new Rmail commands 'rmail-mailing-list-post', 'rmail-mailing-list-archive allow to, respectively, post to, unsubscribe from, request help about, and browse the archives, of the mailing list from which the current email message was delivered. + +** Dictionary + +--- +*** New user option 'dictionary-search-interface'. +Controls how the 'dictionary-search' command prompts for and displays +dictionary definitions. Customize this user option to 'help' to have +'dictionary-search' display definitions in a *Help* buffer and provide +dictionary-based minibuffer completion for word selection. + +--- +*** New user option 'dictionary-read-word-prompt'. +This allows the user to customize the prompt that is used by +'dictionary-search' when asking for a word to search in the +dictionary. + +--- +*** New user option 'dictionary-display-definition-function'. +This allows the user to customize the way in which 'dictionary-search' +displays word definitions. If non-nil, this user option should be set +to a function that displays a word definition obtained from a +dictionary server. The new function +'dictionary-display-definition-in-help-buffer' can be used to display +the definition in a *Help* buffer, instead of the default *Dictionary* +buffer. + +--- +*** New user option 'dictionary-read-word-function'. +This allows the user to customize the way in which 'dictionary-search' +prompts for a word to search in the dictionary. This user option +should be set to a function that lets the user select a word and +returns it as a string. The new function +'dictionary-completing-read-word' can be used to prompt with +completion based on dictionary matches. + +--- +*** New user option 'dictionary-read-dictionary-function'. +This allows the user to customize the way in which 'dictionary-search' +prompts for a dictionary to search in. This user option should be set +to a function that lets the user select a dictionary and returns its +name as a string. The new function +'dictionary-completing-read-dictionary' can be used to prompt with +completion based on dictionaries that the server supports. + + * New Modes and Packages in Emacs 30.1 diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index ba65225692a..8d81b3ec9d8 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -38,6 +38,8 @@ (require 'custom) (require 'dictionary-connection) (require 'button) +(require 'help-mode) +(require 'external-completion) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Stuff for customizing. @@ -247,6 +249,65 @@ dictionary-coding-systems-for-dictionaries ))) :version "28.1") +(defcustom dictionary-read-word-prompt "Search word" + "Prompt string to use when prompting for a word." + :type 'string + :version "30.1") + +(defcustom dictionary-display-definition-function nil + "Function to use for displaying dictionary definitions. +It is called with three string arguments: the word being defined, +the dictionary name, and the full definition." + :type '(choice (const :tag "Dictionary buffer" nil) + (const :tag "Help buffer" + dictionary-display-definition-in-help-buffer) + (function :tag "Custom function")) + :version "30.1") + +(defcustom dictionary-read-word-function #'dictionary-read-word-default + "Function to use for prompting for a word. +It is called with one string argument, the name of the dictionary to use, and +must return a string." + :type '(choice (const :tag "Default" dictionary-read-word-default) + (const :tag "Dictionary-based completion" + dictionary-completing-read-word) + (function :tag "Custom function")) + :version "30.1") + +(defcustom dictionary-read-dictionary-function + #'dictionary-read-dictionary-default + "Function to use for prompting for a dictionary. +It is called with no arguments and must return a string." + :type '(choice (const :tag "Default" dictionary-read-dictionary-default) + (const :tag "Choose among server-provided dictionaries" + dictionary-completing-read-dictionary) + (function :tag "Custom function")) + :version "30.1") + +(defcustom dictionary-search-interface nil + "Controls how `dictionary-search' prompts for words and displays definitions. + +When set to `help', `dictionary-search' displays definitions in a *Help* buffer, +and provides completion for word selection based on dictionary matches. + +Otherwise, `dictionary-search' displays definitions in a *Dictionary* buffer." + :type '(choice (const :tag "Dictionary buffer" nil) + (const :tag "Help buffer" help)) + :set (lambda (symbol value) + (let ((vals (pcase value + ('help '(dictionary-display-definition-in-help-buffer + dictionary-completing-read-word + dictionary-completing-read-dictionary)) + (_ '(nil + dictionary-read-word-default + dictionary-read-dictionary-default))))) + (seq-setq (dictionary-display-definition-function + dictionary-read-word-function + dictionary-read-dictionary-function) + vals)) + (set-default-toplevel-value symbol value)) + :version "30.1") + (defface dictionary-word-definition-face '((((supports (:family "DejaVu Serif"))) (:family "DejaVu Serif")) @@ -366,6 +427,8 @@ dictionary-word-history '() "History list of searched word.") +(defvar dictionary--last-match nil) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Basic function providing startup actions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1139,6 +1202,20 @@ dictionary-search-default ((car (get-char-property (point) 'data))) (t (current-word t)))) +(defun dictionary-read-dictionary-default () + "Prompt for a dictionary name." + (read-string (if dictionary-default-dictionary + (format "Dictionary (%s): " + dictionary-default-dictionary) + "Dictionary: ") + nil nil dictionary-default-dictionary)) + +(defun dictionary-read-word-default (_dictionary) + "Prompt for a word to search in the dictionary." + (let ((default (dictionary-search-default))) + (read-string (format-prompt dictionary-read-word-prompt default) + nil 'dictionary-word-history default))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User callable commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1149,23 +1226,22 @@ dictionary-search It presents the selection or word at point as default input and allows editing it." (interactive - (list (let ((default (dictionary-search-default))) - (read-string (format-prompt "Search word" default) - nil 'dictionary-word-history default)) - (if current-prefix-arg - (read-string (if dictionary-default-dictionary - (format "Dictionary (%s): " dictionary-default-dictionary) - "Dictionary: ") - nil nil dictionary-default-dictionary) - dictionary-default-dictionary))) - - ;; if called by pressing the button - (unless word - (setq word (read-string "Search word: " nil 'dictionary-word-history))) - ;; just in case non-interactively called + (let ((dict + (if current-prefix-arg + (funcall dictionary-read-dictionary-function) + dictionary-default-dictionary))) + (list (funcall dictionary-read-word-function dict) dict))) (unless dictionary (setq dictionary dictionary-default-dictionary)) - (dictionary-new-search (cons word dictionary))) + (if dictionary-display-definition-function + (if-let ((definition (dictionary-define-word word dictionary))) + (funcall dictionary-display-definition-function word dictionary definition) + (user-error "No definition found for \"%s\"" word)) + ;; if called by pressing the button + (unless word + (setq word (read-string "Search word: " nil 'dictionary-word-history))) + ;; just in case non-interactively called + (dictionary-new-search (cons word dictionary)))) ;;;###autoload (defun dictionary-lookup-definition () @@ -1386,5 +1462,102 @@ dictionary-context-menu 'dictionary-separator)) menu) +(defun dictionary-define-word (word dictionary) + "Return the definition of WORD in DICTIONARY, or nil if not found." + (dictionary-send-command + (format "define %s \"%s\"" dictionary word)) + (when (and (= (read (dictionary-read-reply)) 150) + (= (read (dictionary-read-reply)) 151)) + (dictionary-read-answer))) + +(defun dictionary-match-word (word &rest _) + "Return dictionary matches for WORD as a list of strings. +Further arguments are currently ignored." + (unless (string-empty-p word) + (if (string= (car dictionary--last-match) word) + (cdr dictionary--last-match) + (dictionary-send-command + (format "match %s %s \"%s\"" + dictionary-default-dictionary + dictionary-default-strategy + word)) + (when (and (= (read (dictionary-read-reply)) 152)) + (with-temp-buffer + (insert (dictionary-read-answer)) + (goto-char (point-min)) + (let ((result nil)) + (while (not (eobp)) + (search-forward " " nil t) + (push (read (current-buffer)) result) + (search-forward "\n" nil t)) + (setq result (reverse result)) + (setq dictionary--last-match (cons word result)) + result)))))) + +(defun dictionary-completing-read-word (dictionary) + "Prompt for a word with completion based on matches in DICTIONARY." + (let* ((completion-ignore-case t) + (dictionary-default-dictionary dictionary) + (word-at-point (thing-at-point 'word t)) + (default (dictionary-match-word word-at-point))) + (completing-read (format-prompt dictionary-read-word-prompt default) + (external-completion-table 'dictionary-definition + #'dictionary-match-word) + nil t nil 'dictionary-word-history default t))) + +(defun dictionary-dictionaries () + "Return the list of dictionaries the server supports." + (dictionary-send-command "show db") + (when (and (= (read (dictionary-read-reply)) 110)) + (with-temp-buffer + (insert (dictionary-read-answer)) + (goto-char (point-min)) + (let ((result '(("!" . "First matching dictionary") + ("*" . "All dictionaries")))) + (while (not (eobp)) + (push (cons (buffer-substring + (search-forward "\n" nil t) + (1- (search-forward " " nil t))) + (read (current-buffer))) + result)) + (reverse result))))) + +(defun dictionary-completing-read-dictionary () + "Prompt for a dictionary the server supports." + (let* ((dicts (dictionary-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 (format-prompt "Select dictionary" + dictionary-default-dictionary) + dicts nil t nil nil dictionary-default-dictionary))) + +(define-button-type 'help-word + :supertype 'help-xref + 'help-function 'dictionary-search + 'help-echo "mouse-2, RET: describe this word") + +(defun dictionary-display-definition-in-help-buffer (word dictionary definition) + "Display DEFINITION, the definition of WORD in DICTIONARY." + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'dictionary-search word dictionary) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert definition) + ;; Buttonize references to other definitions. These appear as + ;; words enclosed with curly braces. + (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) + dictionary)))))) + (provide 'dictionary) ;;; dictionary.el ends here -- 2.40.1