emacs/guix-utils.el

   1 ;;; guix-utils.el --- General utility functions  -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2014, 2015, 2016 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 (defmacro guix-with-indent (indent &rest body)
  68   "Evaluate BODY and indent inserted text by INDENT number of spaces."
  69   (declare (indent 1) (debug t))
  70   (let ((region-beg-var (make-symbol "region-beg"))
  71         (indent-var     (make-symbol "indent")))
  72     `(let ((,region-beg-var (point))
  73            (,indent-var     ,indent))
  74        ,@body
  75        (unless (zerop ,indent-var)
  76          (indent-rigidly ,region-beg-var (point) ,indent-var)))))
  77
  78 (defun guix-format-insert (val &optional face format)
  79   "Convert VAL into a string and insert it at point.
  80 If FACE is non-nil, propertize VAL with FACE.
  81 If FORMAT is non-nil, format VAL with FORMAT."
  82   (let ((str (guix-get-string val face)))
  83     (insert (if format
  84                 (format format str)
  85               str))))
  86
  87 (cl-defun guix-mapinsert (function sequence separator &key indent column)
  88   "Like `mapconcat' but for inserting text.
  89 Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR
  90 at point between each FUNCTION call.
  91
  92 If INDENT is non-nil, it should be a number of spaces used to
  93 indent each line of the inserted text.
  94
  95 If COLUMN is non-nil, it should be a column number which
  96 shouldn't be exceeded by the inserted text."
  97   (pcase sequence
  98     (`(,first . ,rest)
  99      (let* ((indent (or indent 0))
 100             (max-column (and column (- column indent))))
 101        (guix-with-indent indent
 102          (funcall function first)
 103          (dolist (element rest)
 104            (let ((before-sep-pos (and column (point))))
 105              (insert separator)
 106              (let ((after-sep-pos (and column (point))))
 107                (funcall function element)
 108                (when (and column
 109                           (> (current-column) max-column))
 110                  (save-excursion
 111                    (delete-region before-sep-pos after-sep-pos)
 112                    (goto-char before-sep-pos)
 113                    (insert "\n")))))))))))
 114
 115 (defun guix-insert-button (label &optional type &rest properties)
 116   "Make button of TYPE with LABEL and insert it at point.
 117 See `insert-text-button' for the meaning of PROPERTIES."
 118   (if (null label)
 119       (guix-format-insert nil)
 120     (apply #'insert-text-button label
 121            :type (or type 'button)
 122            properties)))
 123
 124 (defun guix-buttonize (value button-type separator &rest properties)
 125   "Make BUTTON-TYPE button(s) from VALUE.
 126 Return a string with button(s).
 127
 128 VALUE should be a string or a list of strings.  If it is a list
 129 of strings, buttons are separated with SEPARATOR string.
 130
 131 PROPERTIES are passed to `guix-insert-button'."
 132   (with-temp-buffer
 133     (let ((labels (if (listp value) value (list value))))
 134       (guix-mapinsert (lambda (label)
 135                         (apply #'guix-insert-button
 136                                label button-type properties))
 137                       labels
 138                       separator))
 139     (buffer-substring (point-min) (point-max))))
 140
 141 (defun guix-button-type? (symbol)
 142   "Return non-nil, if SYMBOL is a button type."
 143   (and symbol
 144        (get symbol 'button-category-symbol)))
 145
 146 (defun guix-split-insert (val &optional face col separator)
 147   "Convert VAL into a string, split it and insert at point.
 148
 149 If FACE is non-nil, propertize returned string with this FACE.
 150
 151 If COL is non-nil and result string is a one-line string longer
 152 than COL, split it into several short lines.
 153
 154 Separate inserted lines with SEPARATOR."
 155   (if (null val)
 156       (guix-format-insert nil)
 157     (let ((strings (guix-split-string (guix-get-string val) col)))
 158       (guix-mapinsert (lambda (str) (guix-format-insert str face))
 159                       strings
 160                       (or separator "")))))
 161
 162 (defun guix-split-string (str &optional col)
 163   "Split string STR by lines and return list of result strings.
 164 If COL is non-nil, fill STR to this column."
 165   (let ((str (if col
 166                  (guix-get-filled-string str col)
 167                str)))
 168     (split-string str "\n *" t)))
 169
 170 (defun guix-get-filled-string (str col)
 171   "Return string by filling STR to column COL."
 172   (with-temp-buffer
 173     (insert str)
 174     (let ((fill-column col))
 175       (fill-region (point-min) (point-max)))
 176     (buffer-string)))
 177
 178 (defun guix-concat-strings (strings separator &optional location)
 179   "Return new string by concatenating STRINGS with SEPARATOR.
 180 If LOCATION is a symbol `head', add another SEPARATOR to the
 181 beginning of the returned string; if `tail' - add SEPARATOR to
 182 the end of the string; if nil, do not add SEPARATOR; otherwise
 183 add both to the end and to the beginning."
 184   (let ((str (mapconcat #'identity strings separator)))
 185     (cond ((null location)
 186            str)
 187           ((eq location 'head)
 188            (concat separator str))
 189           ((eq location 'tail)
 190            (concat str separator))
 191           (t
 192            (concat separator str separator)))))
 193
 194 (defun guix-hexify (value)
 195   "Convert VALUE to string and hexify it."
 196   (url-hexify-string (guix-get-string value)))
 197
 198 (defun guix-number->bool (number)
 199   "Convert NUMBER to boolean value.
 200 Return nil, if NUMBER is 0; return t otherwise."
 201   (not (zerop number)))
 202
 203 (defun guix-shell-quote-argument (argument)
 204   "Quote shell command ARGUMENT.
 205 This function is similar to `shell-quote-argument', but less strict."
 206   (if (equal argument "")
 207       "''"
 208     (replace-regexp-in-string
 209      "\n" "'\n'"
 210      (replace-regexp-in-string
 211       (rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument))))
 212
 213 (defun guix-symbol-title (symbol)
 214   "Return SYMBOL's name, a string.
 215 This is like `symbol-name', but fancier."
 216   (if (eq symbol 'id)
 217       "ID"
 218     (let ((str (replace-regexp-in-string "-" " " (symbol-name symbol))))
 219       (concat (capitalize (substring str 0 1))
 220               (substring str 1)))))
 221
 222 (defun guix-command-symbol (&optional args)
 223   "Return symbol by concatenating 'guix' and ARGS (strings)."
 224   (intern (guix-concat-strings (cons "guix" args) "-")))
 225
 226 (defun guix-command-string (&optional args)
 227   "Return 'guix ARGS ...' string with quoted shell arguments."
 228   (let ((args (mapcar #'guix-shell-quote-argument args)))
 229     (guix-concat-strings (cons "guix" args) " ")))
 230
 231 (defun guix-copy-as-kill (string &optional no-message?)
 232   "Put STRING into `kill-ring'.
 233 If NO-MESSAGE? is non-nil, do not display a message about it."
 234   (kill-new string)
 235   (unless no-message?
 236     (message "'%s' has been added to kill ring." string)))
 237
 238 (defun guix-copy-command-as-kill (args &optional no-message?)
 239   "Put 'guix ARGS ...' string into `kill-ring'.
 240 See also `guix-copy-as-kill'."
 241   (guix-copy-as-kill (guix-command-string args) no-message?))
 242
 243 (defun guix-compose-buffer-name (base-name postfix)
 244   "Return buffer name by appending BASE-NAME and POSTFIX.
 245
 246 In a simple case the result is:
 247
 248   BASE-NAME: POSTFIX
 249
 250 If BASE-NAME is wrapped by '*', then the result is:
 251
 252   *BASE-NAME: POSTFIX*"
 253   (let ((re (rx string-start
 254                 (group (? "*"))
 255                 (group (*? any))
 256                 (group (? "*"))
 257                 string-end)))
 258     (or (string-match re base-name)
 259         (error "Unexpected error in defining buffer name"))
 260     (let ((first*    (match-string 1 base-name))
 261           (name-body (match-string 2 base-name))
 262           (last*     (match-string 3 base-name)))
 263       ;; Handle the case when buffer name is wrapped by '*'.
 264       (if (and (string= "*" first*)
 265                (string= "*" last*))
 266           (concat "*" name-body ": " postfix "*")
 267         (concat base-name ": " postfix)))))
 268
 269 (defun guix-completing-read (prompt table &optional predicate
 270                              require-match initial-input
 271                              hist def inherit-input-method)
 272   "Same as `completing-read' but return nil instead of an empty string."
 273   (let ((res (completing-read prompt table predicate
 274                               require-match initial-input
 275                               hist def inherit-input-method)))
 276     (unless (string= "" res) res)))
 277
 278 (defun guix-completing-read-multiple (prompt table &optional predicate
 279                                       require-match initial-input
 280                                       hist def inherit-input-method)
 281   "Same as `completing-read-multiple' but remove duplicates in result."
 282   (cl-remove-duplicates
 283    (completing-read-multiple prompt table predicate
 284                              require-match initial-input
 285                              hist def inherit-input-method)
 286    :test #'string=))
 287
 288 (declare-function org-read-date "org" t)
 289
 290 (defun guix-read-date (prompt)
 291   "Prompt for a date or time using `org-read-date'.
 292 Return time value."
 293   (require 'org)
 294   (org-read-date nil t nil prompt))
 295
 296 (defun guix-read-file-name (prompt &optional dir default-filename
 297                                    mustmatch initial predicate)
 298   "Read file name.
 299 This function is similar to `read-file-name' except it also
 300 expands the file name."
 301   (expand-file-name (read-file-name prompt dir default-filename
 302                                     mustmatch initial predicate)))
 303
 304 (defcustom guix-find-file-function #'find-file
 305   "Function used to find a file.
 306 The function is called by `guix-find-file' with a file name as a
 307 single argument."
 308   :type '(choice (function-item find-file)
 309                  (function-item org-open-file)
 310                  (function :tag "Other function"))
 311   :group 'guix)
 312
 313 (defun guix-find-file (file)
 314   "Find FILE if it exists."
 315   (if (file-exists-p file)
 316       (funcall guix-find-file-function file)
 317     (message "File '%s' does not exist." file)))
 318
 319 (defvar url-handler-regexp)
 320
 321 (defun guix-find-file-or-url (file-or-url)
 322   "Find FILE-OR-URL."
 323   (require 'url-handlers)
 324   (let ((file-name-handler-alist
 325          (cons (cons url-handler-regexp 'url-file-handler)
 326                file-name-handler-alist)))
 327     (find-file file-or-url)))
 328
 329 (defmacro guix-while-search (regexp &rest body)
 330   "Evaluate BODY after each search for REGEXP in the current buffer."
 331   (declare (indent 1) (debug t))
 332   `(save-excursion
 333      (goto-char (point-min))
 334      (while (re-search-forward ,regexp nil t)
 335        ,@body)))
 336
 337 (defmacro guix-while-null (&rest body)
 338   "Evaluate BODY until its result becomes non-nil."
 339   (declare (indent 0) (debug t))
 340   (let ((result-var (make-symbol "result")))
 341     `(let (,result-var)
 342        (while (null ,result-var)
 343          (setq ,result-var ,@body))
 344        ,result-var)))
 345
 346 (defun guix-modify (object modifiers)
 347   "Apply MODIFIERS to OBJECT.
 348 OBJECT is passed as an argument to the first function from
 349 MODIFIERS list, the returned result is passed to the second
 350 function from the list and so on.  Return result of the last
 351 modifier call."
 352   (if (null modifiers)
 353       object
 354     (guix-modify (funcall (car modifiers) object)
 355                  (cdr modifiers))))
 356
 357 (defmacro guix-keyword-args-let (args varlist &rest body)
 358   "Parse ARGS, bind variables from VARLIST and eval BODY.
 359
 360 Find keyword values in ARGS, bind them to variables according to
 361 VARLIST, then evaluate BODY.
 362
 363 ARGS is a keyword/value property list.
 364
 365 Each element of VARLIST has a form:
 366
 367   (SYMBOL KEYWORD [DEFAULT-VALUE])
 368
 369 SYMBOL is a varible name.  KEYWORD is a symbol that will be
 370 searched in ARGS for an according value.  If the value of KEYWORD
 371 does not exist, bind SYMBOL to DEFAULT-VALUE or nil.
 372
 373 The rest arguments (that present in ARGS but not in VARLIST) will
 374 be bound to `%foreign-args' variable.
 375
 376 Example:
 377
 378   (guix-keyword-args-let '(:two 8 :great ! :guix is)
 379       ((one :one 1)
 380        (two :two 2)
 381        (foo :smth))
 382     (list one two foo %foreign-args))
 383
 384   => (1 8 nil (:guix is :great !))"
 385   (declare (indent 2))
 386   (let ((args-var (make-symbol "args")))
 387     `(let (,@(mapcar (lambda (spec)
 388                        (pcase-let ((`(,name ,_ ,val) spec))
 389                          (list name val)))
 390                      varlist)
 391            (,args-var ,args)
 392            %foreign-args)
 393        (while ,args-var
 394          (pcase ,args-var
 395            (`(,key ,val . ,rest-args)
 396             (cl-case key
 397               ,@(mapcar (lambda (spec)
 398                           (pcase-let ((`(,name ,key ,_) spec))
 399                             `(,key (setq ,name val))))
 400                         varlist)
 401               (t (setq %foreign-args
 402                        (cl-list* key val %foreign-args))))
 403             (setq ,args-var rest-args))))
 404        ,@body)))
 405
 406 \f
 407 ;;; Alist procedures
 408
 409 (defmacro guix-define-alist-accessor (name assoc-fun)
 410   "Define NAME function to access alist values using ASSOC-FUN."
 411   `(defun ,name (alist &rest keys)
 412      ,(format "Return value from ALIST by KEYS using `%s'.
 413 ALIST is alist of alists of alists ... which can be consecutively
 414 accessed with KEYS."
 415               assoc-fun)
 416      (if (or (null alist) (null keys))
 417          alist
 418        (apply #',name
 419               (cdr (,assoc-fun (car keys) alist))
 420               (cdr keys)))))
 421
 422 (guix-define-alist-accessor guix-assq-value assq)
 423 (guix-define-alist-accessor guix-assoc-value assoc)
 424
 425 (defun guix-alist-put (value alist &rest keys)
 426   "Put (add or replace if exists) VALUE to ALIST using KEYS.
 427 Return the new alist.
 428
 429 ALIST is alist of alists of alists ... which can be consecutively
 430 accessed with KEYS.
 431
 432 Example:
 433
 434   (guix-alist-put
 435    'foo
 436    '((one (a . 1) (b . 2))
 437      (two (m . 7) (n . 8)))
 438    'one 'b)
 439
 440   => ((one (a . 1) (b . foo))
 441       (two (m . 7) (n . 8)))"
 442   (or keys (error "Keys should be specified"))
 443   (guix-alist-put-1 value alist keys))
 444
 445 (defun guix-alist-put-1 (value alist keys)
 446   "Subroutine of `guix-alist-put'."
 447   (cond
 448    ((null keys)
 449     value)
 450    ((null alist)
 451     (list (cons (car keys)
 452                 (guix-alist-put-1 value nil (cdr keys)))))
 453    ((eq (car keys) (caar alist))
 454     (cons (cons (car keys)
 455                 (guix-alist-put-1 value (cdar alist) (cdr keys)))
 456           (cdr alist)))
 457    (t
 458     (cons (car alist)
 459           (guix-alist-put-1 value (cdr alist) keys)))))
 460
 461 (defun guix-alist-put! (value variable &rest keys)
 462   "Modify alist VARIABLE (symbol) by putting VALUE using KEYS.
 463 See `guix-alist-put' for details."
 464   (set variable
 465        (apply #'guix-alist-put value (symbol-value variable) keys)))
 466
 467 \f
 468 ;;; Diff
 469
 470 (defvar guix-diff-switches "-u"
 471   "A string or list of strings specifying switches to be passed to diff.")
 472
 473 (defun guix-diff (old new &optional switches no-async)
 474   "Same as `diff', but use `guix-diff-switches' as default."
 475   (diff old new (or switches guix-diff-switches) no-async))
 476
 477 \f
 478 ;;; Completing readers definers
 479
 480 (defmacro guix-define-reader (name read-fun completions prompt)
 481   "Define NAME function to read from minibuffer.
 482 READ-FUN may be `completing-read', `completing-read-multiple' or
 483 another function with the same arguments."
 484   `(defun ,name (&optional prompt initial-contents)
 485      (,read-fun ,(if prompt
 486                      `(or prompt ,prompt)
 487                    'prompt)
 488                 ,completions nil nil initial-contents)))
 489
 490 (defmacro guix-define-readers (&rest args)
 491   "Define reader functions.
 492
 493 ARGS should have a form [KEYWORD VALUE] ...  The following
 494 keywords are available:
 495
 496   - `completions-var' - variable used to get completions.
 497
 498   - `completions-getter' - function used to get completions.
 499
 500   - `single-reader', `single-prompt' - name of a function to read
 501     a single value, and a prompt for it.
 502
 503   - `multiple-reader', `multiple-prompt' - name of a function to
 504     read multiple values, and a prompt for it.
 505
 506   - `multiple-separator' - if specified, another
 507     `<multiple-reader-name>-string' function returning a string
 508     of multiple values separated the specified separator will be
 509     defined."
 510   (guix-keyword-args-let args
 511       ((completions-var    :completions-var)
 512        (completions-getter :completions-getter)
 513        (single-reader      :single-reader)
 514        (single-prompt      :single-prompt)
 515        (multiple-reader    :multiple-reader)
 516        (multiple-prompt    :multiple-prompt)
 517        (multiple-separator :multiple-separator))
 518     (let ((completions
 519            (cond ((and completions-var completions-getter)
 520                   `(or ,completions-var
 521                        (setq ,completions-var
 522                              (funcall ',completions-getter))))
 523                  (completions-var
 524                   completions-var)
 525                  (completions-getter
 526                   `(funcall ',completions-getter)))))
 527       `(progn
 528          ,(when (and completions-var
 529                      (not (boundp completions-var)))
 530             `(defvar ,completions-var nil))
 531
 532          ,(when single-reader
 533             `(guix-define-reader ,single-reader guix-completing-read
 534                                  ,completions ,single-prompt))
 535
 536          ,(when multiple-reader
 537             `(guix-define-reader ,multiple-reader completing-read-multiple
 538                                  ,completions ,multiple-prompt))
 539
 540          ,(when (and multiple-reader multiple-separator)
 541             (let ((name (intern (concat (symbol-name multiple-reader)
 542                                         "-string"))))
 543               `(defun ,name (&optional prompt initial-contents)
 544                  (guix-concat-strings
 545                   (,multiple-reader prompt initial-contents)
 546                   ,multiple-separator))))))))
 547
 548 \f
 549 ;;; Memoizing
 550
 551 (defun guix-memoize (function)
 552   "Return a memoized version of FUNCTION."
 553   (let ((cache (make-hash-table :test 'equal)))
 554     (lambda (&rest args)
 555       (let ((result (gethash args cache 'not-found)))
 556         (if (eq result 'not-found)
 557             (let ((result (apply function args)))
 558               (puthash args result cache)
 559               result)
 560           result)))))
 561
 562 (defmacro guix-memoized-defun (name arglist docstring &rest body)
 563   "Define a memoized function NAME.
 564 See `defun' for the meaning of arguments."
 565   (declare (doc-string 3) (indent 2))
 566   `(defalias ',name
 567      (guix-memoize (lambda ,arglist ,@body))
 568      ;; Add '(name args ...)' string with real arglist to the docstring,
 569      ;; because *Help* will display '(name &rest ARGS)' for a defined
 570      ;; function (since `guix-memoize' returns a lambda with '(&rest
 571      ;; args)').
 572      ,(format "(%S %s)\n\n%s"
 573               name
 574               (mapconcat #'symbol-name arglist " ")
 575               docstring)))
 576
 577 (defmacro guix-memoized-defalias (symbol definition &optional docstring)
 578   "Set SYMBOL's function definition to memoized version of DEFINITION."
 579   (declare (doc-string 3) (indent 1))
 580   `(defalias ',symbol
 581      (guix-memoize #',definition)
 582      ,(or docstring
 583           (format "Memoized version of `%S'." definition))))
 584
 585 \f
 586 (defvar guix-utils-font-lock-keywords
 587   (eval-when-compile
 588     `((,(rx "(" (group (or "guix-define-reader"
 589                            "guix-define-readers"
 590                            "guix-keyword-args-let"
 591                            "guix-while-null"
 592                            "guix-while-search"
 593                            "guix-with-indent"))
 594             symbol-end)
 595        . 1)
 596       (,(rx "("
 597             (group "guix-memoized-" (or "defun" "defalias"))
 598             symbol-end
 599             (zero-or-more blank)
 600             (zero-or-one
 601              (group (one-or-more (or (syntax word) (syntax symbol))))))
 602        (1 font-lock-keyword-face)
 603        (2 font-lock-function-name-face nil t)))))
 604
 605 (font-lock-add-keywords 'emacs-lisp-mode guix-utils-font-lock-keywords)
 606
 607 (provide 'guix-utils)
 608
 609 ;;; guix-utils.el ends here