Re: A widget-based version of find-cmd

[Michael Heerdegen]

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 -*- 
lexical-binding: t -*-

;; Copyright (C) 2019 Free Software Foundation, Inc

;; Author: Michael Heerdegen <address@hidden>
;; Maintainer: Michael Heerdegen <address@hidden>
;; 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 <http://www.gnu.org/licenses/>.

;;; 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 match 
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 
#'car)))))

(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-get 
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) `(,arity))
                                                  (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 name)))
                          `(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 
,@(widget-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-value 
w)))))
            (widget-value-set find-cmd-widget-preview-widget-2
                              (find-cmd-widget-create-find-call (widget-value 
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 ?⇩))
      (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.