emacs/guix-utils.el

   1 ;;; guix-utils.el --- General utility functions  -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
   4
   5 ;; This file is part of GNU Guix.
   6
   7 ;; GNU Guix is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Guix is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; This file provides auxiliary general functions for guix.el package.
  23
  24 ;;; Code:
  25
  26 (require 'cl-lib)
  27
  28 (defvar guix-true-string "Yes")
  29 (defvar guix-false-string "–")
  30 (defvar guix-list-separator ", ")
  31
  32 (defvar guix-time-format "%F %T"
  33   "String used to format time values.
  34 For possible formats, see `format-time-string'.")
  35
  36 (defun guix-get-string (val &optional face)
  37   "Convert VAL into a string and return it.
  38
  39 VAL can be an expression of any type.
  40 If VAL is t/nil, it is replaced with
  41 `guix-true-string'/`guix-false-string'.
  42 If VAL is list, its elements are concatenated using
  43 `guix-list-separator'.
  44
  45 If FACE is non-nil, propertize returned string with this FACE."
  46   (let ((str (cond
  47               ((stringp val) val)
  48               ((null val) guix-false-string)
  49               ((eq t val) guix-true-string)
  50               ((numberp val) (number-to-string val))
  51               ((listp val) (mapconcat #'guix-get-string
  52                                       val guix-list-separator))
  53               (t (prin1-to-string val)))))
  54     (if (and val face)
  55         (propertize str 'font-lock-face face)
  56       str)))
  57
  58 (defun guix-get-time-string (seconds)
  59   "Return formatted time string from SECONDS.
  60 Use `guix-time-format'."
  61   (format-time-string guix-time-format (seconds-to-time seconds)))
  62
  63 (defun guix-get-one-line (str)
  64   "Return one-line string from a multi-line STR."
  65   (replace-regexp-in-string "\n" " " str))
  66
  67 (defun guix-format-insert (val &optional face format)
  68   "Convert VAL into a string and insert it at point.
  69 If FACE is non-nil, propertize VAL with FACE.
  70 If FORMAT is non-nil, format VAL with FORMAT."
  71   (let ((str (guix-get-string val face)))
  72     (insert (if format
  73                 (format format str)
  74               str))))
  75
  76 (defun guix-mapinsert (function sequence separator)
  77   "Like `mapconcat' but for inserting text.
  78 Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR
  79 at point between each FUNCTION call."
  80   (when sequence
  81     (funcall function (car sequence))
  82     (mapc (lambda (obj)
  83             (insert separator)
  84             (funcall function obj))
  85           (cdr sequence))))
  86
  87 (defun guix-insert-button (label &optional type &rest properties)
  88   "Make button of TYPE with LABEL and insert it at point.
  89 See `insert-text-button' for the meaning of PROPERTIES."
  90   (if (null label)
  91       (guix-format-insert nil)
  92     (apply #'insert-text-button label
  93            :type (or type 'button)
  94            properties)))
  95
  96 (defun guix-split-insert (val &optional face col separator)
  97   "Convert VAL into a string, split it and insert at point.
  98
  99 If FACE is non-nil, propertize returned string with this FACE.
 100
 101 If COL is non-nil and result string is a one-line string longer
 102 than COL, split it into several short lines.
 103
 104 Separate inserted lines with SEPARATOR."
 105   (if (null val)
 106       (guix-format-insert nil)
 107     (let ((strings (guix-split-string (guix-get-string val) col)))
 108       (guix-mapinsert (lambda (str) (guix-format-insert str face))
 109                       strings
 110                       (or separator "")))))
 111
 112 (defun guix-split-string (str &optional col)
 113   "Split string STR by lines and return list of result strings.
 114 If COL is non-nil and STR is a one-line string longer than COL,
 115 split it into several short lines."
 116   (let ((strings (split-string str "\n *")))
 117     (if (and col
 118              (null (cdr strings))       ; if not multi-line
 119              (> (length str) col))
 120         (split-string (guix-get-filled-string str col) "\n")
 121       strings)))
 122
 123 (defun guix-get-filled-string (str col)
 124   "Return string by filling STR to column COL."
 125   (with-temp-buffer
 126     (insert str)
 127     (let ((fill-column col))
 128       (fill-region (point-min) (point-max)))
 129     (buffer-string)))
 130
 131 (defun guix-concat-strings (strings separator &optional location)
 132   "Return new string by concatenating STRINGS with SEPARATOR.
 133 If LOCATION is a symbol `head', add another SEPARATOR to the
 134 beginning of the returned string; if `tail' - add SEPARATOR to
 135 the end of the string; if nil, do not add SEPARATOR; otherwise
 136 add both to the end and to the beginning."
 137   (let ((str (mapconcat #'identity strings separator)))
 138     (cond ((null location)
 139            str)
 140           ((eq location 'head)
 141            (concat separator str))
 142           ((eq location 'tail)
 143            (concat str separator))
 144           (t
 145            (concat separator str separator)))))
 146
 147 (defun guix-shell-quote-argument (argument)
 148   "Quote shell command ARGUMENT.
 149 This function is similar to `shell-quote-argument', but less strict."
 150   (if (equal argument "")
 151       "''"
 152     (replace-regexp-in-string
 153      "\n" "'\n'"
 154      (replace-regexp-in-string
 155       (rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument))))
 156
 157 (defun guix-command-symbol (&optional args)
 158   "Return symbol by concatenating 'guix' and ARGS (strings)."
 159   (intern (guix-concat-strings (cons "guix" args) "-")))
 160
 161 (defun guix-command-string (&optional args)
 162   "Return 'guix ARGS ...' string with quoted shell arguments."
 163   (let ((args (mapcar #'guix-shell-quote-argument args)))
 164     (guix-concat-strings (cons "guix" args) " ")))
 165
 166 (defun guix-copy-as-kill (string &optional no-message?)
 167   "Put STRING into `kill-ring'.
 168 If NO-MESSAGE? is non-nil, do not display a message about it."
 169   (kill-new string)
 170   (unless no-message?
 171     (message "'%s' has been added to kill ring." string)))
 172
 173 (defun guix-copy-command-as-kill (args &optional no-message?)
 174   "Put 'guix ARGS ...' string into `kill-ring'.
 175 See also `guix-copy-as-kill'."
 176   (guix-copy-as-kill (guix-command-string args) no-message?))
 177
 178 (defun guix-completing-read-multiple (prompt table &optional predicate
 179                                       require-match initial-input
 180                                       hist def inherit-input-method)
 181   "Same as `completing-read-multiple' but remove duplicates in result."
 182   (cl-remove-duplicates
 183    (completing-read-multiple prompt table predicate
 184                              require-match initial-input
 185                              hist def inherit-input-method)
 186    :test #'string=))
 187
 188 (declare-function org-read-date "org" t)
 189
 190 (defun guix-read-date (prompt)
 191   "Prompt for a date or time using `org-read-date'.
 192 Return time value."
 193   (require 'org)
 194   (org-read-date nil t nil prompt))
 195
 196 (defcustom guix-find-file-function #'find-file
 197   "Function used to find a file.
 198 The function is called by `guix-find-file' with a file name as a
 199 single argument."
 200   :type '(choice (function-item find-file)
 201                  (function-item org-open-file)
 202                  (function :tag "Other function"))
 203   :group 'guix)
 204
 205 (defun guix-find-file (file)
 206   "Find FILE if it exists."
 207   (if (file-exists-p file)
 208       (funcall guix-find-file-function file)
 209     (message "File '%s' does not exist." file)))
 210
 211 (defvar url-handler-regexp)
 212
 213 (defun guix-find-file-or-url (file-or-url)
 214   "Find FILE-OR-URL."
 215   (require 'url-handlers)
 216   (let ((file-name-handler-alist
 217          (cons (cons url-handler-regexp 'url-file-handler)
 218                file-name-handler-alist)))
 219     (find-file file-or-url)))
 220
 221 (defmacro guix-while-search (regexp &rest body)
 222   "Evaluate BODY after each search for REGEXP in the current buffer."
 223   (declare (indent 1) (debug t))
 224   `(save-excursion
 225      (goto-char (point-min))
 226      (while (re-search-forward ,regexp nil t)
 227        ,@body)))
 228
 229 \f
 230 ;;; Alist accessors
 231
 232 (defmacro guix-define-alist-accessor (name assoc-fun)
 233   "Define NAME function to access alist values using ASSOC-FUN."
 234   `(defun ,name (alist &rest keys)
 235      ,(format "Return value from ALIST by KEYS using `%s'.
 236 ALIST is alist of alists of alists ... which can be consecutively
 237 accessed with KEYS."
 238               assoc-fun)
 239      (if (or (null alist) (null keys))
 240          alist
 241        (apply #',name
 242               (cdr (,assoc-fun (car keys) alist))
 243               (cdr keys)))))
 244
 245 (guix-define-alist-accessor guix-assq-value assq)
 246 (guix-define-alist-accessor guix-assoc-value assoc)
 247
 248 \f
 249 ;;; Diff
 250
 251 (defvar guix-diff-switches "-u"
 252   "A string or list of strings specifying switches to be passed to diff.")
 253
 254 (defun guix-diff (old new &optional switches no-async)
 255   "Same as `diff', but use `guix-diff-switches' as default."
 256   (diff old new (or switches guix-diff-switches) no-async))
 257
 258 \f
 259 ;;; Memoizing
 260
 261 (defun guix-memoize (function)
 262   "Return a memoized version of FUNCTION."
 263   (let ((cache (make-hash-table :test 'equal)))
 264     (lambda (&rest args)
 265       (let ((result (gethash args cache 'not-found)))
 266         (if (eq result 'not-found)
 267             (let ((result (apply function args)))
 268               (puthash args result cache)
 269               result)
 270           result)))))
 271
 272 (defmacro guix-memoized-defun (name arglist docstring &rest body)
 273   "Define a memoized function NAME.
 274 See `defun' for the meaning of arguments."
 275   (declare (doc-string 3) (indent 2))
 276   `(defalias ',name
 277      (guix-memoize (lambda ,arglist ,@body))
 278      ;; Add '(name args ...)' string with real arglist to the docstring,
 279      ;; because *Help* will display '(name &rest ARGS)' for a defined
 280      ;; function (since `guix-memoize' returns a lambda with '(&rest
 281      ;; args)').
 282      ,(format "(%S %s)\n\n%s"
 283               name
 284               (mapconcat #'symbol-name arglist " ")
 285               docstring)))
 286
 287 (defmacro guix-memoized-defalias (symbol definition &optional docstring)
 288   "Set SYMBOL's function definition to memoized version of DEFINITION."
 289   (declare (doc-string 3) (indent 1))
 290   `(defalias ',symbol
 291      (guix-memoize #',definition)
 292      ,(or docstring
 293           (format "Memoized version of `%S'." definition))))
 294
 295 (defvar guix-memoized-font-lock-keywords
 296   (eval-when-compile
 297     `((,(rx "("
 298             (group "guix-memoized-" (or "defun" "defalias"))
 299             symbol-end
 300             (zero-or-more blank)
 301             (zero-or-one
 302              (group (one-or-more (or (syntax word) (syntax symbol))))))
 303        (1 font-lock-keyword-face)
 304        (2 font-lock-function-name-face nil t)))))
 305
 306 (font-lock-add-keywords 'emacs-lisp-mode guix-memoized-font-lock-keywords)
 307
 308 (provide 'guix-utils)
 309
 310 ;;; guix-utils.el ends here