From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Mark Oteiza Newsgroups: gmane.emacs.devel Subject: [PATCH] move read-multiple-choice to own library Date: Sun, 1 Oct 2017 23:05:24 -0400 Message-ID: <20171002030524.gstbjahltwvi7e65@logos.localdomain> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: blaine.gmane.org 1506913547 22453 195.159.176.226 (2 Oct 2017 03:05:47 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Mon, 2 Oct 2017 03:05:47 +0000 (UTC) User-Agent: NeoMutt/20170912-48-0df7d3-dirty To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Mon Oct 02 05:05:39 2017 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dyr33-0004to-O2 for ged-emacs-devel@m.gmane.org; Mon, 02 Oct 2017 05:05:38 +0200 Original-Received: from localhost ([::1]:50429 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dyr3A-00039m-QP for ged-emacs-devel@m.gmane.org; Sun, 01 Oct 2017 23:05:44 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:36677) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dyr2x-00039e-HJ for emacs-devel@gnu.org; Sun, 01 Oct 2017 23:05:33 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dyr2u-0000k5-6x for emacs-devel@gnu.org; Sun, 01 Oct 2017 23:05:31 -0400 Original-Received: from mail-qt0-x229.google.com ([2607:f8b0:400d:c0d::229]:54740) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dyr2t-0000jJ-Nk for emacs-devel@gnu.org; Sun, 01 Oct 2017 23:05:28 -0400 Original-Received: by mail-qt0-x229.google.com with SMTP id i13so5762594qtc.11 for ; Sun, 01 Oct 2017 20:05:27 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=udel-edu.20150623.gappssmtp.com; s=20150623; h=date:from:to:subject:message-id:mime-version:content-disposition :user-agent; bh=pSstB7T8Lr3V+gSCIVRtVh6A7nOSO21UBG6DazByJ1A=; b=T2zgGPUceutFHAO/bFKUw7OnrdRww/0AdnLAubCAJcvOG3HATYSXcyS2c3gKWr5FzZ XyHxEH3ZwXkDTZD/53oPAG5l8G9x5YSo2ro5mtWTrEcKSmBg8rr6Xd9B/rP6cfzRK3ET TRZWTeQzeubcnYR1XSJt0rEHXUcxbHR5gimlsr5RBqGYiz+2L3n/QhtciTpYxwUnxE54 N12ak41iBrjxnbXiizWll9JTcgUZ7WnP7m68oWVOUOd/1q6tWVqae7md9LbvNA0ZTOIG Qw2tgAc/0drlHU0ttZEK7Ux8W73/tIwXQF+QEslGOjRRhTqRxEIuP2NZeBzGhaO0bZcG rbqQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:date:from:to:subject:message-id:mime-version :content-disposition:user-agent; bh=pSstB7T8Lr3V+gSCIVRtVh6A7nOSO21UBG6DazByJ1A=; b=h4qz6SEpEBddnh6dksQ+TB2y79P6lUPpnaPQ5IZu++4+knrhHMgw95ig+ciRxsxV2W RkK6ybdrQd2hkdQaI1r7YjwCShAIOwToJlZ62jPAwmTe4gaoA8PgTCCnBcgZgMYsZCmt MYm+O2iI2FPbSFrfWX43xo7yUaU0wbAdMcMNJ+NvKOvkJ7YNFOupkJOdMUPBRtvgMYMv szGEMAulY9LJhGCK4Uc0XlYvazMvzS9KByfXUz6mGZVTQ7EYcnIOJzSP6QdPWwcFfyI3 aRi5LEAl9Z+Sw3nRLCLfm+9UGEiDQDZnQGfKJB+JxgK0FZNzvDH/TQx6IG0PS2UyYRty D7ug== X-Gm-Message-State: AMCzsaUXjPa8Jf8tcsFAO9oKSdea/eGfZa+FhRHflg9+/tHTk5MKRXQT fo4LxPF1KjlUJlnVgK2H37bB/ilg14M= X-Google-Smtp-Source: AOwi7QAJje1yJT+uUj8wKCTlDWNwynFmapRkoYokYTa9dzogRmbPNIUnZ08GMeyKNAfpYa+PCOMCrg== X-Received: by 10.200.8.53 with SMTP id u50mr557146qth.260.1506913526416; Sun, 01 Oct 2017 20:05:26 -0700 (PDT) Original-Received: from logos.localdomain (pool-173-67-36-61.bltmmd.fios.verizon.net. [173.67.36.61]) by smtp.gmail.com with ESMTPSA id f66sm6140268qkc.25.2017.10.01.20.05.25 for (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Sun, 01 Oct 2017 20:05:25 -0700 (PDT) Content-Disposition: inline X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 2607:f8b0:400d:c0d::229 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:218998 Archived-At: Hi, read-multiple-choice in subr-x.el does not make sense. - r-m-c is in subr-x but is documented in lispref - r-m-c does not fit with the other members of subr-x completing-read-multiple is similar, lives in its own file crm.el and is autoloaded. I would prefer this go to emacs-26. lisp/emacs-lisp/rmc.el | 199 +++++++++++++++++++++++++++++++++++++++++++++++++ lisp/emacs-lisp/subr-x.el | 170 ---------------------------------------------- 2 files changed, 199 insertions(+), 170 deletions(-) diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el new file mode 100644 index 0000000000..417301cde0 --- /dev/null +++ b/lisp/emacs-lisp/rmc.el @@ -0,0 +1,199 @@ +;;; rmc.el --- read from a multiple choice question -*- lexical-binding: t -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 . + +;;; Commentary: + +;;; Code: + +;;;###autoload +(defun read-multiple-choice (prompt choices) + "Ask user a multiple choice question. +PROMPT should be a string that will be displayed as the prompt. + +CHOICES is an alist where the first element in each entry is a +character to be entered, the second element is a short name for +the entry to be displayed while prompting (if there's room, it +might be shortened), and the third, optional entry is a longer +explanation that will be displayed in a help buffer if the user +requests more help. + +This function translates user input into responses by consulting +the bindings in `query-replace-map'; see the documentation of +that variable for more information. In this case, the useful +bindings are `recenter', `scroll-up', and `scroll-down'. If the +user enters `recenter', `scroll-up', or `scroll-down' responses, +perform the requested window recentering or scrolling and ask +again. + +When `use-dialog-box' is t (the default), this function can pop +up a dialog window to collect the user input. That functionality +requires `display-popup-menus-p' to return t. Otherwise, a text +dialog will be used. + +The return value is the matching entry from the CHOICES list. + +Usage example: + +\(read-multiple-choice \"Continue connecting?\" + \\='((?a \"always\") + (?s \"session only\") + (?n \"no\")))" + (let* ((altered-names nil) + (full-prompt + (format + "%s (%s): " + prompt + (mapconcat + (lambda (elem) + (let* ((name (cadr elem)) + (pos (seq-position name (car elem))) + (altered-name + (cond + ;; Not in the name string. + ((not pos) + (format "[%c] %s" (car elem) name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals... + ((display-supports-face-attributes-p + '(:underline t) (window-frame)) + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (push (cons (car elem) altered-name) + altered-names) + altered-name)) + (append choices '((?? "?"))) + ", "))) + tchar buf wrong-char answer) + (save-window-excursion + (save-excursion + (while (not tchar) + (message "%s%s" + (if wrong-char + "Invalid choice. " + "") + full-prompt) + (setq tchar + (if (and (display-popup-menus-p) + last-input-event ; not during startup + (listp last-nonmenu-event) + use-dialog-box) + (x-popup-dialog + t + (cons prompt + (mapcar + (lambda (elem) + (cons (capitalize (cadr elem)) + (car elem))) + choices))) + (condition-case nil + (let ((cursor-in-echo-area t)) + (read-char)) + (error nil)))) + (setq answer (lookup-key query-replace-map (vector tchar) t)) + (setq tchar + (cond + ((eq answer 'recenter) + (recenter) t) + ((eq answer 'scroll-up) + (ignore-errors (scroll-up-command)) t) + ((eq answer 'scroll-down) + (ignore-errors (scroll-down-command)) t) + ((eq answer 'scroll-other-window) + (ignore-errors (scroll-other-window)) t) + ((eq answer 'scroll-other-window-down) + (ignore-errors (scroll-other-window-down)) t) + (t tchar))) + (when (eq tchar t) + (setq wrong-char nil + tchar nil)) + ;; The user has entered an invalid choice, so display the + ;; help messages. + (when (and (not (eq tchar nil)) + (not (assq tchar choices))) + (setq wrong-char (not (memq tchar '(?? ?\C-h))) + tchar nil) + (when wrong-char + (ding)) + (with-help-window (setq buf (get-buffer-create + "*Multiple Choice Help*")) + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (bolp) + (insert line "\n") + (insert line)) + (forward-line 1))))))))))) + (when (buffer-live-p buf) + (kill-buffer buf)) + (assq tchar choices))) + +(provide 'rmc) + +;;; rmc.el ends here diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index edba6550fa..7d1de99b9a 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -245,176 +245,6 @@ string-remove-suffix (substring string 0 (- (length string) (length suffix))) string)) -(defun read-multiple-choice (prompt choices) - "Ask user a multiple choice question. -PROMPT should be a string that will be displayed as the prompt. - -CHOICES is an alist where the first element in each entry is a -character to be entered, the second element is a short name for -the entry to be displayed while prompting (if there's room, it -might be shortened), and the third, optional entry is a longer -explanation that will be displayed in a help buffer if the user -requests more help. - -This function translates user input into responses by consulting -the bindings in `query-replace-map'; see the documentation of -that variable for more information. In this case, the useful -bindings are `recenter', `scroll-up', and `scroll-down'. If the -user enters `recenter', `scroll-up', or `scroll-down' responses, -perform the requested window recentering or scrolling and ask -again. - -When `use-dialog-box' is t (the default), this function can pop -up a dialog window to collect the user input. That functionality -requires `display-popup-menus-p' to return t. Otherwise, a text -dialog will be used. - -The return value is the matching entry from the CHOICES list. - -Usage example: - -\(read-multiple-choice \"Continue connecting?\" - \\='((?a \"always\") - (?s \"session only\") - (?n \"no\")))" - (let* ((altered-names nil) - (full-prompt - (format - "%s (%s): " - prompt - (mapconcat - (lambda (elem) - (let* ((name (cadr elem)) - (pos (seq-position name (car elem))) - (altered-name - (cond - ;; Not in the name string. - ((not pos) - (format "[%c] %s" (car elem) name)) - ;; The prompt character is in the name, so highlight - ;; it on graphical terminals... - ((display-supports-face-attributes-p - '(:underline t) (window-frame)) - (setq name (copy-sequence name)) - (put-text-property pos (1+ pos) - 'face 'read-multiple-choice-face - name) - name) - ;; And put it in [bracket] on non-graphical terminals. - (t - (concat - (substring name 0 pos) - "[" - (upcase (substring name pos (1+ pos))) - "]" - (substring name (1+ pos))))))) - (push (cons (car elem) altered-name) - altered-names) - altered-name)) - (append choices '((?? "?"))) - ", "))) - tchar buf wrong-char answer) - (save-window-excursion - (save-excursion - (while (not tchar) - (message "%s%s" - (if wrong-char - "Invalid choice. " - "") - full-prompt) - (setq tchar - (if (and (display-popup-menus-p) - last-input-event ; not during startup - (listp last-nonmenu-event) - use-dialog-box) - (x-popup-dialog - t - (cons prompt - (mapcar - (lambda (elem) - (cons (capitalize (cadr elem)) - (car elem))) - choices))) - (condition-case nil - (let ((cursor-in-echo-area t)) - (read-char)) - (error nil)))) - (setq answer (lookup-key query-replace-map (vector tchar) t)) - (setq tchar - (cond - ((eq answer 'recenter) - (recenter) t) - ((eq answer 'scroll-up) - (ignore-errors (scroll-up-command)) t) - ((eq answer 'scroll-down) - (ignore-errors (scroll-down-command)) t) - ((eq answer 'scroll-other-window) - (ignore-errors (scroll-other-window)) t) - ((eq answer 'scroll-other-window-down) - (ignore-errors (scroll-other-window-down)) t) - (t tchar))) - (when (eq tchar t) - (setq wrong-char nil - tchar nil)) - ;; The user has entered an invalid choice, so display the - ;; help messages. - (when (and (not (eq tchar nil)) - (not (assq tchar choices))) - (setq wrong-char (not (memq tchar '(?? ?\C-h))) - tchar nil) - (when wrong-char - (ding)) - (with-help-window (setq buf (get-buffer-create - "*Multiple Choice Help*")) - (with-current-buffer buf - (erase-buffer) - (pop-to-buffer buf) - (insert prompt "\n\n") - (let* ((columns (/ (window-width) 25)) - (fill-column 21) - (times 0) - (start (point))) - (dolist (elem choices) - (goto-char start) - (unless (zerop times) - (if (zerop (mod times columns)) - ;; Go to the next "line". - (goto-char (setq start (point-max))) - ;; Add padding. - (while (not (eobp)) - (end-of-line) - (insert (make-string (max (- (* (mod times columns) - (+ fill-column 4)) - (current-column)) - 0) - ?\s)) - (forward-line 1)))) - (setq times (1+ times)) - (let ((text - (with-temp-buffer - (insert (format - "%c: %s\n" - (car elem) - (cdr (assq (car elem) altered-names)))) - (fill-region (point-min) (point-max)) - (when (nth 2 elem) - (let ((start (point))) - (insert (nth 2 elem)) - (unless (bolp) - (insert "\n")) - (fill-region start (point-max)))) - (buffer-string)))) - (goto-char start) - (dolist (line (split-string text "\n")) - (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) - (forward-line 1))))))))))) - (when (buffer-live-p buf) - (kill-buffer buf)) - (assq tchar choices))) - (provide 'subr-x) ;;; subr-x.el ends here