From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED.blaine.gmane.org!not-for-mail From: Michael Heerdegen Newsgroups: gmane.emacs.devel Subject: Re: A widget-based version of find-cmd Date: Fri, 14 Jun 2019 01:35:51 +0200 Message-ID: <875zp9oy7c.fsf@web.de> References: <87v9xrfjyj.fsf@web.de> <871s0ap9g7.fsf@web.de> <0884798f-d83e-4b85-a0dd-fa87833488aa@default> Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Injection-Info: blaine.gmane.org; posting-host="blaine.gmane.org:195.159.176.226"; logging-data="126654"; mail-complaints-to="usenet@blaine.gmane.org" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.0.50 (gnu/linux) Cc: Stefan Monnier , emacs-devel@gnu.org To: Drew Adams Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Jun 14 01:37:16 2019 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([209.51.188.17]) by blaine.gmane.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89) (envelope-from ) id 1hbZHP-000Wl2-AY for ged-emacs-devel@m.gmane.org; Fri, 14 Jun 2019 01:37:15 +0200 Original-Received: from localhost ([::1]:46314 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hbZHN-00073u-4v for ged-emacs-devel@m.gmane.org; Thu, 13 Jun 2019 19:37:13 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:60414) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hbZGi-00072P-T4 for emacs-devel@gnu.org; Thu, 13 Jun 2019 19:36:34 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hbZGW-00057z-Rt for emacs-devel@gnu.org; Thu, 13 Jun 2019 19:36:27 -0400 Original-Received: from mout.web.de ([217.72.192.78]:53115) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hbZGU-00056a-SK for emacs-devel@gnu.org; Thu, 13 Jun 2019 19:36:20 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=web.de; s=dbaedf251592; t=1560468956; bh=fbd+u/U4d2ykTr7zyAs2ePf1UXA7Ws4AIjQBIqEn4LQ=; h=X-UI-Sender-Class:From:To:Cc:Subject:References:Date:In-Reply-To; b=TmF5duUb5Mvczyig/xMn+pReLdGR6LAwUlbQXSV5xHd3TohwTYDRKLIFWyDQqIQ68 l7fF8f8/5UZ1u4Dps+HfMrdZuEfTs3Ek/EHV1otOe6MnczG2RvZXSwqhErZYkfEFzI YqE8fyTOhapJmqaZBpxenmld1L/w7QJ7qvW3KEpE= X-UI-Sender-Class: c548c8c5-30a9-4db5-a2e7-cb6cb037b8f9 Original-Received: from drachen.dragon ([188.98.106.25]) by smtp.web.de (mrweb102 [213.165.67.124]) with ESMTPSA (Nemesis) id 0M6mPA-1iXdSJ3fsq-00wSj6; Fri, 14 Jun 2019 01:35:56 +0200 In-Reply-To: <0884798f-d83e-4b85-a0dd-fa87833488aa@default> (Drew Adams's message of "Mon, 3 Jun 2019 16:28:03 -0700 (PDT)") X-Provags-ID: V03:K1:VoUlQzU1Ass29OicqlZVLxTlqR4tsyI+ct14SIPpUzJqLyJSd8l ji9lZ2QJ7ud+VFXtXYLqoHtSVeEUuXbY2sfVTtOy4+djQaJm6MO10bDWLVbj2XTL6gcfw2E 92kNk0ipzaLVKMffdoNU/+J4ufWsfMbS3mLVsPOfMN/0YDREEJn7Fg0ZdqvTAy6BtKj0lN6 UEYQr6ugtqJVTnUo+4KMQ== X-UI-Out-Filterresults: notjunk:1;V03:K0:nfMorIcAX/I=:z+oK53sBhdM8FooJipd+M0 2fzVyLKuuT9YTDBNQto2yvrgBTeYlm8uAT05khhUvKq7KXIh2dR2i1LVv2aMQGxBvl3eKi0Ue zKzK7VwvAEUkDNPcLmIMNe8g6Dn5ZR0rW/y9ckEysYEuRqa2aRsSNIw6G2Tduadf9w/3gGgxI uZxnQexscSVxk2P7MjB5uIz3IkDk1Tq2pS/eX013hYSQNmIxaX/LsIw+TuYs31gJ+xPqHy+Hc IHxXNeaZMkLzaQDGTxVedOrVF93ev+uCICc3xjVdC3LBsEkWtTu2a5/gWedywXNanNm8vRUaO IR32fhf8XEAXSTvviJI9xkhTRv93IVaUkX+gwsFUo+YI8c48pYiSbSba9giwbzvGvn0ztG46w xS60KryypWw1/Xa9WAhbmEUPda3r54xGVnIHzcokXaKIbCdxeQh1dy2f1ZOOSKVJxROHJlQwY grE1VXTZwXXsp+I5+fYScUtb7GgklNc4zVhZpBS9M5NRxFvATa3dtbfThoinN4BHXN0DWsZrw Fl/a1JN/SCX4gj+/GUzcJLyCDJxkT3AOsrZgv+zIZHD9SqSP6NG+f/AUYurVcgF3fFTwAZdFK XvM9/azqUZA9hEUfA7CkYPUnbMH8dVS3wBZqjSR4Zt2GbJHHnZVWVaSwN242bLslZjjvxNW9L aUPS6+M7g433xDuPY4KLOokaeQpBJJZiI2MzvirsqIJ2tSRs24ubItggRnXZ4fPs4SjhbCwOt BXcBorNZPQ6RyMEcyHyY2kZqcl7xbfLohYdew9tY6w3UOg7+xbCi/M6ZOzLtal2osiHfjFPt X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 217.72.192.78 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.23 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:237567 Archived-At: Ok, attached is the draft/prototype. I made it a separate file since overlaps with find-cmd.el are so small. Main thing left to do is to add the help texts and commentaries. Open questions/ to discuss further: (1) For the find option query I needed to hack into the editable-list widget definition. Would be good if this would be possible out of the box. I guess I have to implement the selection dialog completely myself. I want a query to select an item from a list. Items have annotations, and are in categories. Items should be choosable by using the categories, but not necessarily (if I know I want "name", I don't want to get all the assistance stuff in the way). AFAIK there is nothing predefined I could use, right? I need it as minibuffer completion version and as popup menu. (2) What would also be good would be an upgraded widget that is (i) foldable and, even better (ii) movable with drag and drop to be able to reorder given "find" options without the need to start from the beginning. What already worked out of the box (to my surprise) was to insert items in between in editable-list. I guess the drag-and-drop thing would't be too hard to do (just need to delete the widget and recreate a copy at the drop point). (3) I don't see any obvious/natural way to make the find call become part of some history. I guess it could be nice if (find-dired dir (find-cmd FIND-CMD-S-EXP ...)) would become part of the history of M-: or so. Ok, here is the file - remember: prototype. #+begin_src emacs-lisp ;;; find-cmd-widget.el --- Build a valid find(1) command with widgets -*- l= exical-binding: t -*- ;; Copyright (C) 2019 Free Software Foundation, Inc ;; Author: Michael Heerdegen ;; Maintainer: Michael Heerdegen ;; Created: 10 Jun 2019 ;; Keywords: convenience ;; Compatibility: GNU Emacs 26 ;; Version: 0.1 ;; Package-Requires: ((emacs "26")) ;; This file is not 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 GNU Emacs. If not, see . ;;; Commentary: ;; ... ;;; Code: ;;;; Requirements (require 'widget) (require 'find-cmd) (require 'subr-x) (require 'cus-edit) (eval-when-compile (require 'wid-edit)) ;;;; The other stuff (defvar find-cmd-widget-find-arg-alist '((and find-and "combiners") (not find-not "combiners") (or find-or "combiners") (a find-and "combiners") (n find-not "combiners") (o find-or "combiners") (prune find-prune "combiners") ;; switches (L (0) "switches") (P (0) "switches") (H (0) "switches") ;; generic tests (amin (1) "generic tests") (anewer (1) "generic tests") (atime (1) "generic tests") (cmin (1) "generic tests") (cnewer (1) "generic tests") (ctime (1) "generic tests") (empty (0) "generic tests") (executable (0) "generic tests") (false (0) "generic tests") (fstype (1) "generic tests") (gid (1) "generic tests") (group (1) "generic tests") (ilname (1) "generic tests") (iname (1) "generic tests") (inum (1) "generic tests") (ipath (1) "generic tests") (iregex (1) "generic tests") (iwholename (1) "generic tests") (links (1) "generic tests") (lname (1) "generic tests") (mmin (1) "generic tests") (mtime (1) "generic tests") (name (1) "generic tests" nil "shell glob pattern; needs to ma= tch the complete name") (newer (1) "generic tests") (nogroup (0) "generic tests") (nouser (0) "generic tests") (path (1) "generic tests") (perm (0) "generic tests") (readable (0) "generic tests") (regex (1) "generic tests") (samefile (1) "generic tests") (size (1) "generic tests") (true (0) "generic tests") (type (1) "generic tests") (uid (1) "generic tests") (used (1) "generic tests") (user (1) "generic tests") (wholename (1) "generic tests") (writable (0) "generic tests") (xtype (nil) "generic tests") ;; normal options (always true) (daystart (0) "normal options (always true)") (depth (0) "normal options (always true)") (maxdepth (1) "normal options (always true)") (mindepth (1) "normal options (always true)") (mount (0) "normal options (always true)") (noleaf (0) "normal options (always true)") (ignore_readdir_race (0) "normal options (always true)") (noignore_readdir_race (0) "normal options (always true)") (regextype (1) "normal options (always true)") (xdev (0) "normal options (always true)") ;; actions (delete (0) "actions") (print0 (0) "actions") (printf (1) "actions") (fprintf (2) "actions") (print (0) "actions") (fprint0 (1) "actions") (fprint (1) "actions") (ls (0) "actions") (fls (1) "actions") (prune (0) "actions") (quit (0) "actions") ;; these need to be terminated with a ; (exec (1 find-command t) "these need to be terminated with a ;") (ok (1 find-command t) "these need to be terminated with a ;") (execdir (1 find-command t) "these need to be terminated with a ;") (okdir (1 find-command t) "these need to be terminated with a ;")) "Doc...") (defvar-local find-cmd-widget-main-widget nil) (defvar-local find-cmd-widget-preview-widget-1 nil) (defvar-local find-cmd-widget-preview-widget-2 nil) (defun find-cmd-widget-create-find-cmd (sexp) `(let ((default-directory ,(car sexp))) (find-cmd ,@(cadr sexp)))) (defun find-cmd-widget-create-find-call (sexp) (let ((default-directory (car sexp))) (apply #'find-cmd (cadr sexp)))) (defalias 'find-cmd-orig-widget-choose (symbol-function 'widget-choose)) (defun find-cmd-widget-menu-choice-action (&rest args) (cl-letf (((symbol-function #'widget-choose) #'find-cmd-widget--widget-choose)) (apply #'widget-choice-action args))) (defun find-cmd-widget--widget-choose (title items &optional event) (let ((widget-menu-max-size 100)) (if event ;; mouse click (progn (x-popup-menu event (apply #'list title (seq-group-by (lambda (item) (nth 2 (assoc (intern (car item)) find-cmd-widget-find= -arg-alist))) items)))) (find-cmd-orig-widget-choose title (cl-sort items #'string< :key #'ca= r))))) (define-widget 'find-expr 'lazy "Doc..." :format "...:\n%v" :type (cl-flet ((just-true (lambda (_) t)) (value-get-1 (lambda (command) (lambda (w) (list command (widget-field-value-ge= t w)))))) `(editable-list :args ((menu-choice :action find-cmd-widget-menu-choice-action :args ,(append (delq nil (mapcar (pcase-lambda ((and `(,name ,(or (and (pred listp) `(,arit= y)) (let arity nil)) . ,rest) (let name-string (symbol-name name)) (let hint (nth 2 rest)))) (ignore name rest) (and arity (if (zerop arity) `(choice-item :tag ,name-string :value-get ,(lambda (_w) (list na= me))) `(editable-field :menu-tag ,name-string :size 6 :validate ,#'just-true :format ,(concat name-string ": %v" (and hint (format " (%s)" = hint)) "\n") :value-get ,(value-get-1 name) :keymap widget-field-keymap)))) find-cmd-widget-find-arg-alist)) (mapcar (lambda (combiner) (let ((sname (symbol-name combiner))) `(find-expr :tag ,sname :format ,(concat sname "\n%v") :value-inline ,(lambda (w) `((,combiner ,@(widge= t-child-value-get w))))))) '(or and not prune)))))))) (define-widget 'find 'group "Doc..." :format "%v" :notify (lambda (w &rest _) (widget-value-set find-cmd-widget-preview-widget-1 (string-trim-right (pp-to-string (find-cmd-widget-create-find-cmd (widget-va= lue w))))) (widget-value-set find-cmd-widget-preview-widget-2 (find-cmd-widget-create-find-call (widget-val= ue w)))) :args `((item :format "find %[path%]: %v\n\n" :value ,default-directory :action (lambda (w &rest _) (widget-value-set w (read-directory-name "Dir: " (widget-value w))))) (find-expr :format "expr:\n%v"))) (defun find-cmd-widget-find-action (&rest _) (interactive) (async-shell-command (widget-value find-cmd-widget-preview-widget-2))) (defun find-cmd-widget-find-dired-action (&rest _) (interactive) (let ((sexp (widget-value find-cmd-widget-main-widget))) (find-dired (car sexp) (mapconcat #'find-to-string (cadr sexp) "")))) ;;;###autoload (defun find-cmd-widget () "Doc..." (interactive) (let ((buf (generate-new-buffer "*Widget Find*"))) (pop-to-buffer buf) (kill-all-local-variables) (let ((inhibit-read-only t)) (erase-buffer)) (remove-overlays) (custom--initialize-widget-variables) (setq-local find-cmd-widget-main-widget (widget-create 'find)) (let ((arrow ?=E2=87=A9)) (when (char-displayable-p arrow) (insert (propertize (concat " " (string arrow)) 'face '(:height = 2.0)) "\n")) (setq-local find-cmd-widget-preview-widget-1 (widget-create 'item :value "???")) (when (char-displayable-p arrow) (insert (propertize (concat " " (string arrow)) 'face '(:height = 2.0)) "\n")) (setq-local find-cmd-widget-preview-widget-2 (widget-create 'item :value "???"))) (insert "\n") (widget-create 'push-button :tag "find!" :help-echo "Run constructed find command" :action #'find-cmd-widget-find-action) (insert " ") (widget-create 'push-button :tag "find-dired!" :help-echo "Run constructed find command as find-dired" :action #'find-cmd-widget-find-dired-action) (insert "\n") (use-local-map (let ((map (make-sparse-keymap))) (set-keymap-parent map widget-keymap) (define-key map [(control ?c) (control ?c)] #'find-cmd-widget-find-dired-action) map)) (widget-setup) (goto-char (point-min)))) (provide 'find-cmd-widget) ;;; find-cmd-widget.el ends here #+end_src Regards, Michael.