2015-06-06 19:14:13 +00:00
|
|
|
|
;;; guix-utils.el --- General utility functions -*- lexical-binding: t -*-
|
2014-08-27 12:44:17 +00:00
|
|
|
|
|
2015-06-06 19:14:13 +00:00
|
|
|
|
;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
|
2014-08-27 12:44:17 +00:00
|
|
|
|
|
|
|
|
|
;; This file is part of GNU Guix.
|
|
|
|
|
|
|
|
|
|
;; GNU Guix 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 Guix 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 <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
|
|
|
|
;; This file provides auxiliary general functions for guix.el package.
|
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
emacs: Support font-locking.
Avoid breaking highlighting after adding new font-lock keywords.
* emacs/guix-base.el (guix-insert-package-strings): Use 'propertize' instead
of 'guix-get-string'.
* emacs/guix-info.el (guix, guix-action, guix-file, guix-url,
guix-package-location, guix-package-name): New button types.
(guix-info-insert-action-button, guix-info-insert-file-path,
guix-info-insert-url, guix-package-info-insert-location,
guix-package-info-insert-full-names,
guix-package-info-insert-non-unique-text): Adjust for 'guix-insert-button'
and button types.
(guix-package-info-name-button): New face.
(guix-package-info-define-insert-inputs): Use it. Add new button types.
(guix-package-info-insert-full-name): Remove.
* emacs/guix-utils.el (guix-get-string): Replace 'face' with 'font-lock-face'.
(guix-insert-button): Adjust for using button types.
2014-09-27 20:59:08 +00:00
|
|
|
|
(require 'cl-lib)
|
2014-08-27 12:44:17 +00:00
|
|
|
|
|
|
|
|
|
(defvar guix-true-string "Yes")
|
|
|
|
|
(defvar guix-false-string "–")
|
|
|
|
|
(defvar guix-list-separator ", ")
|
|
|
|
|
|
|
|
|
|
(defvar guix-time-format "%F %T"
|
|
|
|
|
"String used to format time values.
|
|
|
|
|
For possible formats, see `format-time-string'.")
|
|
|
|
|
|
|
|
|
|
(defun guix-get-string (val &optional face)
|
|
|
|
|
"Convert VAL into a string and return it.
|
|
|
|
|
|
|
|
|
|
VAL can be an expression of any type.
|
|
|
|
|
If VAL is t/nil, it is replaced with
|
|
|
|
|
`guix-true-string'/`guix-false-string'.
|
|
|
|
|
If VAL is list, its elements are concatenated using
|
|
|
|
|
`guix-list-separator'.
|
|
|
|
|
|
|
|
|
|
If FACE is non-nil, propertize returned string with this FACE."
|
|
|
|
|
(let ((str (cond
|
|
|
|
|
((stringp val) val)
|
|
|
|
|
((null val) guix-false-string)
|
|
|
|
|
((eq t val) guix-true-string)
|
|
|
|
|
((numberp val) (number-to-string val))
|
|
|
|
|
((listp val) (mapconcat #'guix-get-string
|
|
|
|
|
val guix-list-separator))
|
|
|
|
|
(t (prin1-to-string val)))))
|
|
|
|
|
(if (and val face)
|
emacs: Support font-locking.
Avoid breaking highlighting after adding new font-lock keywords.
* emacs/guix-base.el (guix-insert-package-strings): Use 'propertize' instead
of 'guix-get-string'.
* emacs/guix-info.el (guix, guix-action, guix-file, guix-url,
guix-package-location, guix-package-name): New button types.
(guix-info-insert-action-button, guix-info-insert-file-path,
guix-info-insert-url, guix-package-info-insert-location,
guix-package-info-insert-full-names,
guix-package-info-insert-non-unique-text): Adjust for 'guix-insert-button'
and button types.
(guix-package-info-name-button): New face.
(guix-package-info-define-insert-inputs): Use it. Add new button types.
(guix-package-info-insert-full-name): Remove.
* emacs/guix-utils.el (guix-get-string): Replace 'face' with 'font-lock-face'.
(guix-insert-button): Adjust for using button types.
2014-09-27 20:59:08 +00:00
|
|
|
|
(propertize str 'font-lock-face face)
|
2014-08-27 12:44:17 +00:00
|
|
|
|
str)))
|
|
|
|
|
|
|
|
|
|
(defun guix-get-time-string (seconds)
|
|
|
|
|
"Return formatted time string from SECONDS.
|
|
|
|
|
Use `guix-time-format'."
|
|
|
|
|
(format-time-string guix-time-format (seconds-to-time seconds)))
|
|
|
|
|
|
|
|
|
|
(defun guix-get-one-line (str)
|
|
|
|
|
"Return one-line string from a multi-line STR."
|
|
|
|
|
(replace-regexp-in-string "\n" " " str))
|
|
|
|
|
|
|
|
|
|
(defun guix-format-insert (val &optional face format)
|
|
|
|
|
"Convert VAL into a string and insert it at point.
|
|
|
|
|
If FACE is non-nil, propertize VAL with FACE.
|
|
|
|
|
If FORMAT is non-nil, format VAL with FORMAT."
|
|
|
|
|
(let ((str (guix-get-string val face)))
|
|
|
|
|
(insert (if format
|
|
|
|
|
(format format str)
|
|
|
|
|
str))))
|
|
|
|
|
|
|
|
|
|
(defun guix-mapinsert (function sequence separator)
|
|
|
|
|
"Like `mapconcat' but for inserting text.
|
|
|
|
|
Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR
|
|
|
|
|
at point between each FUNCTION call."
|
|
|
|
|
(when sequence
|
|
|
|
|
(funcall function (car sequence))
|
|
|
|
|
(mapc (lambda (obj)
|
|
|
|
|
(insert separator)
|
|
|
|
|
(funcall function obj))
|
|
|
|
|
(cdr sequence))))
|
|
|
|
|
|
emacs: Support font-locking.
Avoid breaking highlighting after adding new font-lock keywords.
* emacs/guix-base.el (guix-insert-package-strings): Use 'propertize' instead
of 'guix-get-string'.
* emacs/guix-info.el (guix, guix-action, guix-file, guix-url,
guix-package-location, guix-package-name): New button types.
(guix-info-insert-action-button, guix-info-insert-file-path,
guix-info-insert-url, guix-package-info-insert-location,
guix-package-info-insert-full-names,
guix-package-info-insert-non-unique-text): Adjust for 'guix-insert-button'
and button types.
(guix-package-info-name-button): New face.
(guix-package-info-define-insert-inputs): Use it. Add new button types.
(guix-package-info-insert-full-name): Remove.
* emacs/guix-utils.el (guix-get-string): Replace 'face' with 'font-lock-face'.
(guix-insert-button): Adjust for using button types.
2014-09-27 20:59:08 +00:00
|
|
|
|
(defun guix-insert-button (label &optional type &rest properties)
|
|
|
|
|
"Make button of TYPE with LABEL and insert it at point.
|
2014-08-27 12:44:17 +00:00
|
|
|
|
See `insert-text-button' for the meaning of PROPERTIES."
|
|
|
|
|
(if (null label)
|
|
|
|
|
(guix-format-insert nil)
|
emacs: Support font-locking.
Avoid breaking highlighting after adding new font-lock keywords.
* emacs/guix-base.el (guix-insert-package-strings): Use 'propertize' instead
of 'guix-get-string'.
* emacs/guix-info.el (guix, guix-action, guix-file, guix-url,
guix-package-location, guix-package-name): New button types.
(guix-info-insert-action-button, guix-info-insert-file-path,
guix-info-insert-url, guix-package-info-insert-location,
guix-package-info-insert-full-names,
guix-package-info-insert-non-unique-text): Adjust for 'guix-insert-button'
and button types.
(guix-package-info-name-button): New face.
(guix-package-info-define-insert-inputs): Use it. Add new button types.
(guix-package-info-insert-full-name): Remove.
* emacs/guix-utils.el (guix-get-string): Replace 'face' with 'font-lock-face'.
(guix-insert-button): Adjust for using button types.
2014-09-27 20:59:08 +00:00
|
|
|
|
(apply #'insert-text-button label
|
|
|
|
|
:type (or type 'button)
|
2014-08-27 12:44:17 +00:00
|
|
|
|
properties)))
|
|
|
|
|
|
|
|
|
|
(defun guix-split-insert (val &optional face col separator)
|
|
|
|
|
"Convert VAL into a string, split it and insert at point.
|
|
|
|
|
|
|
|
|
|
If FACE is non-nil, propertize returned string with this FACE.
|
|
|
|
|
|
|
|
|
|
If COL is non-nil and result string is a one-line string longer
|
|
|
|
|
than COL, split it into several short lines.
|
|
|
|
|
|
|
|
|
|
Separate inserted lines with SEPARATOR."
|
|
|
|
|
(if (null val)
|
|
|
|
|
(guix-format-insert nil)
|
|
|
|
|
(let ((strings (guix-split-string (guix-get-string val) col)))
|
|
|
|
|
(guix-mapinsert (lambda (str) (guix-format-insert str face))
|
|
|
|
|
strings
|
|
|
|
|
(or separator "")))))
|
|
|
|
|
|
|
|
|
|
(defun guix-split-string (str &optional col)
|
|
|
|
|
"Split string STR by lines and return list of result strings.
|
|
|
|
|
If COL is non-nil and STR is a one-line string longer than COL,
|
|
|
|
|
split it into several short lines."
|
|
|
|
|
(let ((strings (split-string str "\n *")))
|
|
|
|
|
(if (and col
|
|
|
|
|
(null (cdr strings)) ; if not multi-line
|
|
|
|
|
(> (length str) col))
|
|
|
|
|
(split-string (guix-get-filled-string str col) "\n")
|
|
|
|
|
strings)))
|
|
|
|
|
|
|
|
|
|
(defun guix-get-filled-string (str col)
|
|
|
|
|
"Return string by filling STR to column COL."
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(insert str)
|
|
|
|
|
(let ((fill-column col))
|
|
|
|
|
(fill-region (point-min) (point-max)))
|
|
|
|
|
(buffer-string)))
|
|
|
|
|
|
2015-08-12 12:44:22 +00:00
|
|
|
|
(defun guix-concat-strings (strings separator &optional location)
|
|
|
|
|
"Return new string by concatenating STRINGS with SEPARATOR.
|
|
|
|
|
If LOCATION is a symbol `head', add another SEPARATOR to the
|
|
|
|
|
beginning of the returned string; if `tail' - add SEPARATOR to
|
|
|
|
|
the end of the string; if nil, do not add SEPARATOR; otherwise
|
|
|
|
|
add both to the end and to the beginning."
|
|
|
|
|
(let ((str (mapconcat #'identity strings separator)))
|
|
|
|
|
(cond ((null location)
|
|
|
|
|
str)
|
|
|
|
|
((eq location 'head)
|
|
|
|
|
(concat separator str))
|
|
|
|
|
((eq location 'tail)
|
|
|
|
|
(concat str separator))
|
|
|
|
|
(t
|
|
|
|
|
(concat separator str separator)))))
|
|
|
|
|
|
2015-08-16 08:09:39 +00:00
|
|
|
|
(defun guix-shell-quote-argument (argument)
|
|
|
|
|
"Quote shell command ARGUMENT.
|
|
|
|
|
This function is similar to `shell-quote-argument', but less strict."
|
|
|
|
|
(if (equal argument "")
|
|
|
|
|
"''"
|
|
|
|
|
(replace-regexp-in-string
|
|
|
|
|
"\n" "'\n'"
|
|
|
|
|
(replace-regexp-in-string
|
|
|
|
|
(rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-symbol (&optional args)
|
|
|
|
|
"Return symbol by concatenating 'guix' and ARGS (strings)."
|
|
|
|
|
(intern (guix-concat-strings (cons "guix" args) "-")))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-string (&optional args)
|
|
|
|
|
"Return 'guix ARGS ...' string with quoted shell arguments."
|
|
|
|
|
(let ((args (mapcar #'guix-shell-quote-argument args)))
|
|
|
|
|
(guix-concat-strings (cons "guix" args) " ")))
|
|
|
|
|
|
2015-08-16 08:11:37 +00:00
|
|
|
|
(defun guix-copy-as-kill (string &optional no-message?)
|
|
|
|
|
"Put STRING into `kill-ring'.
|
|
|
|
|
If NO-MESSAGE? is non-nil, do not display a message about it."
|
|
|
|
|
(kill-new string)
|
|
|
|
|
(unless no-message?
|
|
|
|
|
(message "'%s' has been added to kill ring." string)))
|
|
|
|
|
|
|
|
|
|
(defun guix-copy-command-as-kill (args &optional no-message?)
|
|
|
|
|
"Put 'guix ARGS ...' string into `kill-ring'.
|
|
|
|
|
See also `guix-copy-as-kill'."
|
|
|
|
|
(guix-copy-as-kill (guix-command-string args) no-message?))
|
|
|
|
|
|
2014-08-27 12:44:17 +00:00
|
|
|
|
(defun guix-completing-read-multiple (prompt table &optional predicate
|
|
|
|
|
require-match initial-input
|
|
|
|
|
hist def inherit-input-method)
|
|
|
|
|
"Same as `completing-read-multiple' but remove duplicates in result."
|
|
|
|
|
(cl-remove-duplicates
|
|
|
|
|
(completing-read-multiple prompt table predicate
|
|
|
|
|
require-match initial-input
|
|
|
|
|
hist def inherit-input-method)
|
|
|
|
|
:test #'string=))
|
|
|
|
|
|
2014-10-16 17:35:47 +00:00
|
|
|
|
(declare-function org-read-date "org" t)
|
|
|
|
|
|
|
|
|
|
(defun guix-read-date (prompt)
|
|
|
|
|
"Prompt for a date or time using `org-read-date'.
|
|
|
|
|
Return time value."
|
|
|
|
|
(require 'org)
|
|
|
|
|
(org-read-date nil t nil prompt))
|
|
|
|
|
|
2015-08-30 15:51:09 +00:00
|
|
|
|
(defcustom guix-find-file-function #'find-file
|
|
|
|
|
"Function used to find a file.
|
|
|
|
|
The function is called by `guix-find-file' with a file name as a
|
|
|
|
|
single argument."
|
|
|
|
|
:type '(choice (function-item find-file)
|
|
|
|
|
(function-item org-open-file)
|
|
|
|
|
(function :tag "Other function"))
|
|
|
|
|
:group 'guix)
|
|
|
|
|
|
2014-11-10 12:29:04 +00:00
|
|
|
|
(defun guix-find-file (file)
|
|
|
|
|
"Find FILE if it exists."
|
|
|
|
|
(if (file-exists-p file)
|
2015-08-30 15:51:09 +00:00
|
|
|
|
(funcall guix-find-file-function file)
|
2014-11-10 12:29:04 +00:00
|
|
|
|
(message "File '%s' does not exist." file)))
|
|
|
|
|
|
2015-09-13 18:30:05 +00:00
|
|
|
|
(defvar url-handler-regexp)
|
|
|
|
|
|
|
|
|
|
(defun guix-find-file-or-url (file-or-url)
|
|
|
|
|
"Find FILE-OR-URL."
|
|
|
|
|
(require 'url-handlers)
|
|
|
|
|
(let ((file-name-handler-alist
|
|
|
|
|
(cons (cons url-handler-regexp 'url-file-handler)
|
|
|
|
|
file-name-handler-alist)))
|
|
|
|
|
(find-file file-or-url)))
|
|
|
|
|
|
2015-08-12 12:28:55 +00:00
|
|
|
|
(defmacro guix-while-search (regexp &rest body)
|
|
|
|
|
"Evaluate BODY after each search for REGEXP in the current buffer."
|
|
|
|
|
(declare (indent 1) (debug t))
|
|
|
|
|
`(save-excursion
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(while (re-search-forward ,regexp nil t)
|
|
|
|
|
,@body)))
|
|
|
|
|
|
2015-08-12 12:37:20 +00:00
|
|
|
|
(defun guix-any (pred lst)
|
|
|
|
|
"Test whether any element from LST satisfies PRED.
|
|
|
|
|
If so, return the return value from the successful PRED call.
|
|
|
|
|
Return nil otherwise."
|
|
|
|
|
(when lst
|
|
|
|
|
(or (funcall pred (car lst))
|
|
|
|
|
(guix-any pred (cdr lst)))))
|
|
|
|
|
|
2015-08-16 04:11:57 +00:00
|
|
|
|
|
|
|
|
|
;;; Alist accessors
|
|
|
|
|
|
|
|
|
|
(defmacro guix-define-alist-accessor (name assoc-fun)
|
|
|
|
|
"Define NAME function to access alist values using ASSOC-FUN."
|
|
|
|
|
`(defun ,name (alist &rest keys)
|
|
|
|
|
,(format "Return value from ALIST by KEYS using `%s'.
|
|
|
|
|
ALIST is alist of alists of alists ... which can be consecutively
|
|
|
|
|
accessed with KEYS."
|
|
|
|
|
assoc-fun)
|
|
|
|
|
(if (or (null alist) (null keys))
|
|
|
|
|
alist
|
|
|
|
|
(apply #',name
|
|
|
|
|
(cdr (,assoc-fun (car keys) alist))
|
|
|
|
|
(cdr keys)))))
|
|
|
|
|
|
|
|
|
|
(guix-define-alist-accessor guix-assq-value assq)
|
|
|
|
|
(guix-define-alist-accessor guix-assoc-value assoc)
|
|
|
|
|
|
emacs: Add interface for comparing generations.
Suggested by Ludovic Courtès.
* doc/emacs.texi (Emacs List buffer): Document new key bindings.
* emacs/guix-base.el (guix-generation-packages-buffer-name-function,
guix-generation-packages-update-buffer, guix-output-name-width): New
variables.
(guix-generation-file, guix-manifest-file, guix-generation-packages,
guix-generation-packages-buffer-name-default,
guix-generation-packages-buffer-name-long,
guix-generation-packages-buffer-name, guix-generation-packages-buffer,
guix-generation-insert-package, guix-generation-insert-packages,
guix-profile-generation-manifest-file,
guix-profile-generation-packages-buffer): New procedures.
* emacs/guix-list.el: Add key bindings for comparing generations.
(guix-generation-list-generations-to-compare,
guix-generation-list-show-added-packages,
guix-generation-list-show-removed-packages, guix-generation-list-compare,
guix-generation-list-ediff-manifests, guix-generation-list-diff-manifests,
guix-generation-list-ediff-packages, guix-generation-list-diff-packages,
guix-generation-list-ediff, guix-generation-list-diff): New procedures.
* emacs/guix-messages.el (guix-messages): Add 'generation-diff' search type.
(guix-message-outputs-by-diff): New procedure.
* emacs/guix-utils.el (guix-diff-switches): New variable.
(guix-diff): New procedure.
* emacs/guix-main.scm (package/output-sexps): Handle 'generation-diff' search
type.
(manifest-entry->package-specification,
manifest-entries->package-specifications, generation-package-specifications,
generation-package-specifications+paths, generation-difference): New
procedures.
2014-11-02 10:58:21 +00:00
|
|
|
|
|
|
|
|
|
;;; Diff
|
|
|
|
|
|
|
|
|
|
(defvar guix-diff-switches "-u"
|
|
|
|
|
"A string or list of strings specifying switches to be passed to diff.")
|
|
|
|
|
|
|
|
|
|
(defun guix-diff (old new &optional switches no-async)
|
|
|
|
|
"Same as `diff', but use `guix-diff-switches' as default."
|
|
|
|
|
(diff old new (or switches guix-diff-switches) no-async))
|
|
|
|
|
|
2015-06-06 19:14:13 +00:00
|
|
|
|
|
|
|
|
|
;;; Memoizing
|
|
|
|
|
|
|
|
|
|
(defun guix-memoize (function)
|
|
|
|
|
"Return a memoized version of FUNCTION."
|
|
|
|
|
(let ((cache (make-hash-table :test 'equal)))
|
|
|
|
|
(lambda (&rest args)
|
|
|
|
|
(let ((result (gethash args cache 'not-found)))
|
|
|
|
|
(if (eq result 'not-found)
|
|
|
|
|
(let ((result (apply function args)))
|
|
|
|
|
(puthash args result cache)
|
|
|
|
|
result)
|
|
|
|
|
result)))))
|
|
|
|
|
|
|
|
|
|
(defmacro guix-memoized-defun (name arglist docstring &rest body)
|
|
|
|
|
"Define a memoized function NAME.
|
|
|
|
|
See `defun' for the meaning of arguments."
|
|
|
|
|
(declare (doc-string 3) (indent 2))
|
|
|
|
|
`(defalias ',name
|
|
|
|
|
(guix-memoize (lambda ,arglist ,@body))
|
|
|
|
|
;; Add '(name args ...)' string with real arglist to the docstring,
|
|
|
|
|
;; because *Help* will display '(name &rest ARGS)' for a defined
|
|
|
|
|
;; function (since `guix-memoize' returns a lambda with '(&rest
|
|
|
|
|
;; args)').
|
|
|
|
|
,(format "(%S %s)\n\n%s"
|
|
|
|
|
name
|
|
|
|
|
(mapconcat #'symbol-name arglist " ")
|
|
|
|
|
docstring)))
|
|
|
|
|
|
2015-08-16 03:46:52 +00:00
|
|
|
|
(defmacro guix-memoized-defalias (symbol definition &optional docstring)
|
|
|
|
|
"Set SYMBOL's function definition to memoized version of DEFINITION."
|
|
|
|
|
(declare (doc-string 3) (indent 1))
|
|
|
|
|
`(defalias ',symbol
|
|
|
|
|
(guix-memoize #',definition)
|
|
|
|
|
,(or docstring
|
|
|
|
|
(format "Memoized version of `%S'." definition))))
|
|
|
|
|
|
|
|
|
|
(defvar guix-memoized-font-lock-keywords
|
|
|
|
|
(eval-when-compile
|
|
|
|
|
`((,(rx "("
|
|
|
|
|
(group "guix-memoized-" (or "defun" "defalias"))
|
|
|
|
|
symbol-end
|
|
|
|
|
(zero-or-more blank)
|
|
|
|
|
(zero-or-one
|
|
|
|
|
(group (one-or-more (or (syntax word) (syntax symbol))))))
|
|
|
|
|
(1 font-lock-keyword-face)
|
|
|
|
|
(2 font-lock-function-name-face nil t)))))
|
|
|
|
|
|
|
|
|
|
(font-lock-add-keywords 'emacs-lisp-mode guix-memoized-font-lock-keywords)
|
|
|
|
|
|
2014-08-27 12:44:17 +00:00
|
|
|
|
(provide 'guix-utils)
|
|
|
|
|
|
|
|
|
|
;;; guix-utils.el ends here
|