08/37: emacs: Add 'guix-keyword-args-let'.

[Alex Kost]

alezost pushed a commit to branch wip-refactor-emacs-ui
in repository guix.

commit d4fe9f17c3fce36e3a3e050b927dfa0711222c44
Author: Alex Kost <address@hidden>
Date:   Wed Nov 18 22:28:13 2015 +0300

    emacs: Add 'guix-keyword-args-let'.
    
    * emacs/guix-utils.el (guix-keyword-args-let): New macro.
      (guix-utils-font-lock-keywords): Add it.
    * emacs/guix-base.el (guix-define-buffer-type): Use it.
    * emacs/guix-list.el (guix-list-define-entry-type): Use it.
    * emacs/guix-read.el (guix-define-readers): Use it.
---
 emacs/guix-base.el  |  106 +++++++++++++++++++++++---------------------------
 emacs/guix-list.el  |   70 +++++++++++++++-------------------
 emacs/guix-read.el  |   28 ++++----------
 emacs/guix-utils.el |   52 ++++++++++++++++++++++++-
 4 files changed, 139 insertions(+), 117 deletions(-)

diff --git a/emacs/guix-base.el b/emacs/guix-base.el
index 91b52db..f55e1c6 100644
--- a/emacs/guix-base.el
+++ b/emacs/guix-base.el
@@ -382,63 +382,55 @@ following keywords are available:
          (buf-name-var   (intern (concat prefix "-buffer-name")))
          (revert-var     (intern (concat prefix "-revert-no-confirm")))
          (history-var    (intern (concat prefix "-history-size")))
-         (params-var     (intern (concat prefix "-required-params")))
-         (buf-name-val   (format "*Guix %s %s*" Entry-type-str Buf-type-str))
-         (revert-val     nil)
-         (history-val    20)
-         (params-val     '(id)))
-
-    ;; Process the keyword args.
-    (while (keywordp (car args))
-      (pcase (pop args)
-       (`:required     (setq params-val (pop args)))
-       (`:history-size (setq history-val (pop args)))
-       (`:revert       (setq revert-val (pop args)))
-        (`:buffer-name  (setq buf-name-val (pop args)))
-       (_ (pop args))))
-
-    `(progn
-       (defgroup ,group nil
-         ,(concat Buf-type-str " buffer with " entry-str ".")
-         :prefix ,(concat prefix "-")
-         :group ',(intern (concat "guix-" buf-type-str)))
-
-       (defgroup ,faces-group nil
-         ,(concat "Faces for " buf-type-str " buffer with " entry-str ".")
-         :group ',(intern (concat "guix-" buf-type-str "-faces")))
-
-       (defcustom ,buf-name-var ,buf-name-val
-         ,(concat "Default name of the " buf-str " for displaying " entry-str 
".")
-         :type 'string
-         :group ',group)
-
-       (defcustom ,history-var ,history-val
-         ,(concat "Maximum number of items saved in the history of the " 
buf-str ".\n"
-                  "If 0, the history is disabled.")
-         :type 'integer
-         :group ',group)
-
-       (defcustom ,revert-var ,revert-val
-         ,(concat "If non-nil, do not ask to confirm for reverting the " 
buf-str ".")
-         :type 'boolean
-         :group ',group)
-
-       (defvar ,params-var ',params-val
-         ,(concat "List of required " entry-type-str " parameters.\n\n"
-                  "Displayed parameters and parameters from this list are 
received\n"
-                  "for each " entry-type-str ".\n\n"
-                  "May be a special value `all', in which case all supported\n"
-                  "parameters are received (this may be very slow for a big 
number\n"
-                  "of entries).\n\n"
-                  "Do not remove `id' from this list as it is required for\n"
-                  "identifying an entry."))
-
-       (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str)
-         ,(concat "Major mode for displaying information about " entry-str 
".\n\n"
-                  "\\{" mode-map-str "}")
-         (setq-local revert-buffer-function 'guix-revert-buffer)
-         (setq-local guix-history-size ,history-var)
-         (and (fboundp ',mode-init-fun) (,mode-init-fun))))))
+         (params-var     (intern (concat prefix "-required-params"))))
+    (guix-keyword-args-let args
+        ((params-val :required '(id))
+         (history-val :history-size 20)
+         (revert-val :revert)
+         (buf-name-val :buffer-name
+                       (format "*Guix %s %s*" Entry-type-str Buf-type-str)))
+      `(progn
+         (defgroup ,group nil
+           ,(concat Buf-type-str " buffer with " entry-str ".")
+           :prefix ,(concat prefix "-")
+           :group ',(intern (concat "guix-" buf-type-str)))
+
+         (defgroup ,faces-group nil
+           ,(concat "Faces for " buf-type-str " buffer with " entry-str ".")
+           :group ',(intern (concat "guix-" buf-type-str "-faces")))
+
+         (defcustom ,buf-name-var ,buf-name-val
+           ,(concat "Default name of the " buf-str " for displaying " 
entry-str ".")
+           :type 'string
+           :group ',group)
+
+         (defcustom ,history-var ,history-val
+           ,(concat "Maximum number of items saved in the history of the " 
buf-str ".\n"
+                    "If 0, the history is disabled.")
+           :type 'integer
+           :group ',group)
+
+         (defcustom ,revert-var ,revert-val
+           ,(concat "If non-nil, do not ask to confirm for reverting the " 
buf-str ".")
+           :type 'boolean
+           :group ',group)
+
+         (defvar ,params-var ',params-val
+           ,(concat "List of required " entry-type-str " parameters.\n\n"
+                    "Displayed parameters and parameters from this list are 
received\n"
+                    "for each " entry-type-str ".\n\n"
+                    "May be a special value `all', in which case all 
supported\n"
+                    "parameters are received (this may be very slow for a big 
number\n"
+                    "of entries).\n\n"
+                    "Do not remove `id' from this list as it is required for\n"
+                    "identifying an entry."))
+
+         (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str)
+           ,(concat "Major mode for displaying information about " entry-str 
".\n\n"
+                    "\\{" mode-map-str "}")
+           (setq-local revert-buffer-function 'guix-revert-buffer)
+           (setq-local guix-history-size ,history-var)
+           (and (fboundp ',mode-init-fun) (,mode-init-fun)))))))
 
 (put 'guix-define-buffer-type 'lisp-indent-function 'defun)
 
diff --git a/emacs/guix-list.el b/emacs/guix-list.el
index f0e2019..3e846a3 100644
--- a/emacs/guix-list.el
+++ b/emacs/guix-list.el
@@ -416,45 +416,37 @@ This macro defines the following functions:
          (prefix         (concat "guix-" entry-type-str "-list"))
          (mode-str       (concat prefix "-mode"))
          (init-fun       (intern (concat prefix "-mode-initialize")))
-         (marks-var      (intern (concat prefix "-mark-alist")))
-         (marks-val      nil)
-         (sort-key       nil)
-         (invert-sort    nil))
-
-    ;; Process the keyword args.
-    (while (keywordp (car args))
-      (pcase (pop args)
-        (`:sort-key    (setq sort-key (pop args)))
-        (`:invert-sort (setq invert-sort (pop args)))
-       (`:marks       (setq marks-val (pop args)))
-       (_ (pop args))))
-
-    `(progn
-       (defvar ,marks-var ',marks-val
-         ,(concat "Alist of additional marks for `" mode-str "'.\n"
-                  "Marks from this list are added to `guix-list-mark-alist'."))
-
-       ,@(mapcar (lambda (mark-spec)
-                   (let* ((mark-name (car mark-spec))
-                          (mark-name-str (symbol-name mark-name)))
-                     `(defun ,(intern (concat prefix "-mark-" mark-name-str 
"-simple")) ()
-                        ,(concat "Put '" mark-name-str "' mark and move to the 
next line.\n"
-                                 "Also add the current entry to 
`guix-list-marked'.")
-                        (interactive)
-                        (guix-list--mark ',mark-name t))))
-                 marks-val)
-
-       (defun ,init-fun ()
-         ,(concat "Initial settings for `" mode-str "'.")
-         ,(when sort-key
-            `(setq tabulated-list-sort-key
-                   (guix-list-tabulated-sort-key
-                    ',entry-type ',sort-key ,invert-sort)))
-         (setq tabulated-list-format
-               (guix-list-tabulated-format ',entry-type))
-         (setq-local guix-list-mark-alist
-                     (append guix-list-mark-alist ,marks-var))
-         (tabulated-list-init-header)))))
+         (marks-var      (intern (concat prefix "-mark-alist"))))
+    (guix-keyword-args-let args
+        ((sort-key :sort-key)
+         (invert-sort :invert-sort)
+         (marks-val :marks))
+      `(progn
+         (defvar ,marks-var ',marks-val
+           ,(concat "Alist of additional marks for `" mode-str "'.\n"
+                    "Marks from this list are added to 
`guix-list-mark-alist'."))
+
+         ,@(mapcar (lambda (mark-spec)
+                     (let* ((mark-name (car mark-spec))
+                            (mark-name-str (symbol-name mark-name)))
+                       `(defun ,(intern (concat prefix "-mark-" mark-name-str 
"-simple")) ()
+                          ,(concat "Put '" mark-name-str "' mark and move to 
the next line.\n"
+                                   "Also add the current entry to 
`guix-list-marked'.")
+                          (interactive)
+                          (guix-list--mark ',mark-name t))))
+                   marks-val)
+
+         (defun ,init-fun ()
+           ,(concat "Initial settings for `" mode-str "'.")
+           ,(when sort-key
+              `(setq tabulated-list-sort-key
+                     (guix-list-tabulated-sort-key
+                      ',entry-type ',sort-key ,invert-sort)))
+           (setq tabulated-list-format
+                 (guix-list-tabulated-format ',entry-type))
+           (setq-local guix-list-mark-alist
+                       (append guix-list-mark-alist ,marks-var))
+           (tabulated-list-init-header))))))
 
 (put 'guix-list-define-entry-type 'lisp-indent-function 'defun)
 
diff --git a/emacs/guix-read.el b/emacs/guix-read.el
index e60af9c..82eccbd 100644
--- a/emacs/guix-read.el
+++ b/emacs/guix-read.el
@@ -66,26 +66,14 @@ keywords are available:
     `<multiple-reader-name>-string' function returning a string
     of multiple values separated the specified separator will be
     defined."
-  (let (completions-var
-        completions-getter
-        single-reader
-        single-prompt
-        multiple-reader
-        multiple-prompt
-        multiple-separator)
-
-    ;; Process the keyword args.
-    (while (keywordp (car args))
-      (pcase (pop args)
-        (`:completions-var    (setq completions-var    (pop args)))
-        (`:completions-getter (setq completions-getter (pop args)))
-        (`:single-reader      (setq single-reader      (pop args)))
-        (`:single-prompt      (setq single-prompt      (pop args)))
-        (`:multiple-reader    (setq multiple-reader    (pop args)))
-        (`:multiple-prompt    (setq multiple-prompt    (pop args)))
-        (`:multiple-separator (setq multiple-separator (pop args)))
-       (_ (pop args))))
-
+  (guix-keyword-args-let args
+      ((completions-var    :completions-var)
+       (completions-getter :completions-getter)
+       (single-reader      :single-reader)
+       (single-prompt      :single-prompt)
+       (multiple-reader    :multiple-reader)
+       (multiple-prompt    :multiple-prompt)
+       (multiple-separator :multiple-separator))
     (let ((completions
            (cond ((and completions-var completions-getter)
                   `(or ,completions-var
diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el
index e24b58f..3748350 100644
--- a/emacs/guix-utils.el
+++ b/emacs/guix-utils.el
@@ -257,6 +257,55 @@ modifier call."
     (guix-modify (funcall (car modifiers) object)
                  (cdr modifiers))))
 
+(defmacro guix-keyword-args-let (args varlist &rest body)
+  "Parse ARGS, bind variables from VARLIST and eval BODY.
+
+Find keyword values in ARGS, bind them to variables according to
+VARLIST, then evaluate BODY.
+
+ARGS is a keyword/value property list.
+
+Each element of VARLIST has a form:
+
+  (SYMBOL KEYWORD [DEFAULT-VALUE])
+
+SYMBOL is a varible name.  KEYWORD is a symbol that will be
+searched in ARGS for an according value.  If the value of KEYWORD
+does not exist, bind SYMBOL to DEFAULT-VALUE or nil.
+
+The rest arguments (that present in ARGS but not in VARLIST) will
+be bound to `%foreign-args' variable.
+
+Example:
+
+  (guix-keyword-args-let '(:two 8 :great ! :guix is)
+      ((one :one 1)
+       (two :two 2)
+       (foo :smth))
+    (list one two foo %foreign-args))
+
+  => (1 8 nil (:guix is :great !))"
+  (declare (indent 2))
+  (let ((args-var (make-symbol "args")))
+    `(let (,@(mapcar (lambda (spec)
+                       (pcase-let ((`(,name ,_ ,val) spec))
+                         (list name val)))
+                     varlist)
+           (,args-var ,args)
+           %foreign-args)
+       (while ,args-var
+         (pcase ,args-var
+           (`(,key ,val . ,rest-args)
+            (cl-case key
+              ,@(mapcar (lambda (spec)
+                          (pcase-let ((`(,name ,key ,_) spec))
+                            `(,key (setq ,name val))))
+                        varlist)
+              (t (setq %foreign-args
+                       (cl-list* key val %foreign-args))))
+            (setq ,args-var rest-args))))
+       ,@body)))
+
 
 ;;; Alist accessors
 
@@ -326,7 +375,8 @@ See `defun' for the meaning of arguments."
 
 (defvar guix-utils-font-lock-keywords
   (eval-when-compile
-    `((,(rx "(" (group "guix-with-indent")
+    `((,(rx "(" (group (or "guix-keyword-args-let"
+                           "guix-with-indent"))
             symbol-end)
        . 1)
       (,(rx "("