diff options
| author | Alex Kost <alezost@gmail.com> | 2014-08-27 16:44:17 +0400 |
|---|---|---|
| committer | Alex Kost <alezost@gmail.com> | 2014-09-03 23:50:35 +0400 |
| commit | 457f60fa068c7becf60841daa2b6fc5121aedead (patch) | |
| tree | 8cae5e141a6c5c643255b6777e19c063010cf6f0 | |
| parent | a423555d3c4314f8347d75b050d7daf6e594281f (diff) | |
Add Emacs user interface.
* configure.ac (emacsuidir): New variable.
(AC_CONFIG_FILES): Add 'emacs/guix-init.el', 'emacs/guix-helper.scm'.
* Makefile.am: Include 'emacs.am'.
* emacs.am: New file.
* doc/emacs.texi: New file.
* doc/guix.texi: Include 'emacs.texi'.
* emacs/guix-backend.el: New file.
* emacs/guix-base.el: New file.
* emacs/guix-helper.scm.in: New file.
* emacs/guix-history.el: New file.
* emacs/guix-info.el: New file.
* emacs/guix-init.el.in: New file.
* emacs/guix-list.el: New file.
* emacs/guix-main.scm: New file.
* emacs/guix-utils.el: New file.
* emacs/guix.el: New file.
| -rw-r--r-- | .gitignore | 5 | ||||
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | configure.ac | 7 | ||||
| -rw-r--r-- | doc/emacs.texi | 321 | ||||
| -rw-r--r-- | doc/guix.texi | 3 | ||||
| -rw-r--r-- | emacs.am | 43 | ||||
| -rw-r--r-- | emacs/guix-backend.el | 301 | ||||
| -rw-r--r-- | emacs/guix-base.el | 607 | ||||
| -rw-r--r-- | emacs/guix-helper.scm.in | 64 | ||||
| -rw-r--r-- | emacs/guix-history.el | 92 | ||||
| -rw-r--r-- | emacs/guix-info.el | 556 | ||||
| -rw-r--r-- | emacs/guix-init.el.in | 14 | ||||
| -rw-r--r-- | emacs/guix-list.el | 586 | ||||
| -rw-r--r-- | emacs/guix-main.scm | 603 | ||||
| -rw-r--r-- | emacs/guix-utils.el | 160 | ||||
| -rw-r--r-- | emacs/guix.el | 141 |
16 files changed, 3507 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore index dacd234c9b3..a424a397c4e 100644 --- a/.gitignore +++ b/.gitignore | |||
| @@ -105,3 +105,8 @@ GTAGS | |||
| 105 | /nix-setuid-helper | 105 | /nix-setuid-helper |
| 106 | /nix/scripts/guix-authenticate | 106 | /nix/scripts/guix-authenticate |
| 107 | /nix/scripts/offload | 107 | /nix/scripts/offload |
| 108 | /emacs/Makefile.in | ||
| 109 | /emacs/Makefile | ||
| 110 | /emacs/guix-autoloads.el | ||
| 111 | /emacs/guix-helper.scm | ||
| 112 | /emacs/guix-init.el | ||
diff --git a/Makefile.am b/Makefile.am index d25eeeb76e7..156c560665c 100644 --- a/Makefile.am +++ b/Makefile.am | |||
| @@ -277,6 +277,10 @@ AM_DISTCHECK_CONFIGURE_FLAGS = \ | |||
| 277 | --with-nix-prefix="$(NIX_PREFIX)" \ | 277 | --with-nix-prefix="$(NIX_PREFIX)" \ |
| 278 | --enable-daemon | 278 | --enable-daemon |
| 279 | 279 | ||
| 280 | dist_emacsui_DATA = emacs/guix-main.scm | ||
| 281 | nodist_emacsui_DATA = emacs/guix-helper.scm | ||
| 282 | include emacs.am | ||
| 283 | |||
| 280 | dist-hook: sync-descriptions gen-ChangeLog assert-no-store-file-names | 284 | dist-hook: sync-descriptions gen-ChangeLog assert-no-store-file-names |
| 281 | distcheck-hook: assert-binaries-available assert-final-inputs-self-contained | 285 | distcheck-hook: assert-binaries-available assert-final-inputs-self-contained |
| 282 | 286 | ||
diff --git a/configure.ac b/configure.ac index 71b3ddacaa3..698dd857847 100644 --- a/configure.ac +++ b/configure.ac | |||
| @@ -174,4 +174,11 @@ AC_CONFIG_FILES([scripts/guix], [chmod +x scripts/guix]) | |||
| 174 | AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) | 174 | AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) |
| 175 | AC_CONFIG_FILES([test-env], [chmod +x test-env]) | 175 | AC_CONFIG_FILES([test-env], [chmod +x test-env]) |
| 176 | 176 | ||
| 177 | dnl Emacs interface. | ||
| 178 | AM_PATH_LISPDIR | ||
| 179 | emacsuidir="${guilemoduledir}/guix/emacs" | ||
| 180 | AC_SUBST([emacsuidir]) | ||
| 181 | AC_CONFIG_FILES([emacs/guix-init.el | ||
| 182 | emacs/guix-helper.scm]) | ||
| 183 | |||
| 177 | AC_OUTPUT | 184 | AC_OUTPUT |
diff --git a/doc/emacs.texi b/doc/emacs.texi new file mode 100644 index 00000000000..55feb1bf9fd --- /dev/null +++ b/doc/emacs.texi | |||
| @@ -0,0 +1,321 @@ | |||
| 1 | @node Emacs Interface | ||
| 2 | @section Emacs Interface | ||
| 3 | |||
| 4 | @cindex emacs | ||
| 5 | GNU Guix comes with a visual user interface for GNU@tie{}Emacs, known | ||
| 6 | as ``guix.el''. It can be used for routine package management tasks, | ||
| 7 | pretty much like the @command{guix package} command (@pxref{Invoking | ||
| 8 | guix package}). Specifically, ``guix.el'' makes it easy to: | ||
| 9 | |||
| 10 | @itemize | ||
| 11 | @item browse and display packages and generations; | ||
| 12 | @item search, install, upgrade and remove packages; | ||
| 13 | @item display packages from previous generations; | ||
| 14 | @item do some other useful things. | ||
| 15 | @end itemize | ||
| 16 | |||
| 17 | @menu | ||
| 18 | * Initial Setup: emacs Initial Setup. Preparing @file{~/.emacs}. | ||
| 19 | * Usage: emacs Usage. Using the interface. | ||
| 20 | * Configuration: emacs Configuration. Configuring the interface. | ||
| 21 | @end menu | ||
| 22 | |||
| 23 | @node emacs Initial Setup | ||
| 24 | @subsection Initial Setup | ||
| 25 | |||
| 26 | To be able to use ``guix.el'', you need to install the following | ||
| 27 | packages: | ||
| 28 | |||
| 29 | @itemize | ||
| 30 | @item | ||
| 31 | @uref{http://www.gnu.org/software/emacs/, GNU Emacs}, version 24.3 or | ||
| 32 | later; | ||
| 33 | |||
| 34 | @item | ||
| 35 | @uref{http://nongnu.org/geiser/, Geiser}, version 0.3 or later: it is | ||
| 36 | used for interacting with the Guile process. | ||
| 37 | |||
| 38 | @end itemize | ||
| 39 | |||
| 40 | When it is done, add the following into your init file (@pxref{Init | ||
| 41 | File,,, emacs, The Emacs Editor}): | ||
| 42 | |||
| 43 | @example | ||
| 44 | (require 'guix-init nil t) | ||
| 45 | @end example | ||
| 46 | |||
| 47 | However there is a chance that @code{load-path} of your Emacs does not | ||
| 48 | contain a directory with ``guix.el'' (usually it is | ||
| 49 | @file{/usr/share/emacs/site-lisp/}). In that case you need to add it | ||
| 50 | before requiring (@pxref{Lisp Libraries,,, emacs, The Emacs Editor}): | ||
| 51 | |||
| 52 | @example | ||
| 53 | (add-to-list 'load-path "/path/to/directory-with-guix.el") | ||
| 54 | (require 'guix-init) | ||
| 55 | @end example | ||
| 56 | |||
| 57 | Do not worry about the efficiency of that @code{require} thing. It will | ||
| 58 | not load the whole ``guix.el'' package, it will just autoload the main | ||
| 59 | interactive commands (@pxref{Autoload,,, elisp, Emacs Lisp}). | ||
| 60 | |||
| 61 | |||
| 62 | @node emacs Usage | ||
| 63 | @subsection Usage | ||
| 64 | |||
| 65 | Once ``guix.el'' has been successfully configured, you should be able to | ||
| 66 | use commands for displaying packages and generations. This information | ||
| 67 | can be displayed in a ``list'' or ``info'' buffer. | ||
| 68 | |||
| 69 | @menu | ||
| 70 | * Commands: emacs Commands. @kbd{M-x guix-@dots{}} | ||
| 71 | * General information: emacs General info. Common for both interfaces. | ||
| 72 | * ``List'' buffer: emacs List buffer. List-like interface. | ||
| 73 | * ``Info'' buffer: emacs Info buffer. Help-like interface. | ||
| 74 | @end menu | ||
| 75 | |||
| 76 | @node emacs Commands | ||
| 77 | @subsubsection Commands | ||
| 78 | |||
| 79 | You may use the following commands to display packages and generations: | ||
| 80 | |||
| 81 | @table @kbd | ||
| 82 | @item M-x guix-all-available-packages | ||
| 83 | @itemx M-x guix-newest-available-packages | ||
| 84 | Display all/newest available packages. | ||
| 85 | |||
| 86 | @item M-x guix-installed-packages | ||
| 87 | Display all packages installed in the current profile. | ||
| 88 | |||
| 89 | @item M-x guix-obsolete-packages | ||
| 90 | Display obsolete packages (the packages that are installed in the | ||
| 91 | current profile but cannot be found among available packages). | ||
| 92 | |||
| 93 | @item M-x guix-search-by-name | ||
| 94 | Display package(s) with the specified name. | ||
| 95 | |||
| 96 | @item M-x guix-search-by-regexp | ||
| 97 | Search for packages by a specified regexp. By default ``name'', | ||
| 98 | ``synopsis'' and ``description'' of the packages will be searched. This | ||
| 99 | can be changed by modifying @code{guix-search-params} variable. | ||
| 100 | |||
| 101 | @item M-x guix-generations | ||
| 102 | List generations for the current profile. With numeric prefix, show so | ||
| 103 | many last generations. | ||
| 104 | |||
| 105 | @end table | ||
| 106 | |||
| 107 | It is possible to change the currently used profile with | ||
| 108 | @kbd{M-x@tie{}guix-set-current-profile}. This has the same effect as | ||
| 109 | specifying @code{--profile} option for @command{guix package} | ||
| 110 | (@pxref{Invoking guix package}). | ||
| 111 | |||
| 112 | @node emacs General info | ||
| 113 | @subsubsection General information | ||
| 114 | |||
| 115 | The following keys are available for both ``list'' and ``info'' types of | ||
| 116 | buffers: | ||
| 117 | |||
| 118 | @table @kbd | ||
| 119 | @item l | ||
| 120 | @itemx r | ||
| 121 | Go backward/forward by the history of the displayed results (this | ||
| 122 | history is similar to the history of the Emacs @code{help-mode} or | ||
| 123 | @code{Info-mode}). | ||
| 124 | |||
| 125 | @item g | ||
| 126 | Revert current buffer: update information about the displayed | ||
| 127 | packages/generations and redisplay it. | ||
| 128 | |||
| 129 | @item R | ||
| 130 | Redisplay current buffer (without updating information). | ||
| 131 | |||
| 132 | @item C-c C-z | ||
| 133 | Go to the Guix REPL (@pxref{The REPL,,, geiser, Geiser User Manual}). | ||
| 134 | |||
| 135 | @item h | ||
| 136 | @itemx ? | ||
| 137 | Describe current mode to see all available bindings. | ||
| 138 | |||
| 139 | @end table | ||
| 140 | |||
| 141 | @emph{Hint:} If you need several ``list'' or ``info'' buffers, you can | ||
| 142 | simlpy @kbd{M-x clone-buffer} them, and each buffer will have its own | ||
| 143 | history. | ||
| 144 | |||
| 145 | @emph{Warning:} Name/version pairs cannot be used to identify packages | ||
| 146 | (because a name is not necessarily unique), so ``guix.el'' uses special | ||
| 147 | identifiers that live only during a guile session, so if the Guix REPL | ||
| 148 | was restarted, you may want to revert ``list'' buffer (by pressing | ||
| 149 | @kbd{g}). | ||
| 150 | |||
| 151 | @node emacs List buffer | ||
| 152 | @subsubsection ``List'' buffer | ||
| 153 | |||
| 154 | An interface of a ``list'' buffer is similar to the interface provided | ||
| 155 | by ``package.el'' (@pxref{Package Menu,,, emacs, The Emacs Editor}). | ||
| 156 | |||
| 157 | Default key bindings available for both ``package-list'' and | ||
| 158 | ``generation-list'' buffers: | ||
| 159 | |||
| 160 | @table @kbd | ||
| 161 | @item m | ||
| 162 | Mark the current entry. | ||
| 163 | @item M | ||
| 164 | Mark all entries. | ||
| 165 | @item u | ||
| 166 | Unmark the current entry. | ||
| 167 | @item @key{DEL} | ||
| 168 | Unmark backward. | ||
| 169 | @item U | ||
| 170 | Unmark all entries. | ||
| 171 | @item S | ||
| 172 | Sort entries by a specified column. | ||
| 173 | @end table | ||
| 174 | |||
| 175 | A ``package-list'' buffer additionally provides the following bindings: | ||
| 176 | |||
| 177 | @table @kbd | ||
| 178 | @item @key{RET} | ||
| 179 | Describe marked packages (display available information in a | ||
| 180 | ``package-info'' buffer). | ||
| 181 | @item i | ||
| 182 | Mark a package for installation (with prefix, prompt for output(s) to | ||
| 183 | install). | ||
| 184 | @item d | ||
| 185 | Mark a package for deletion. | ||
| 186 | @item ^ | ||
| 187 | Mark a package for upgrading. | ||
| 188 | @item x | ||
| 189 | Execute actions on marked packages. | ||
| 190 | @end table | ||
| 191 | |||
| 192 | A ``generation-list'' buffer additionally provides the following | ||
| 193 | bindings: | ||
| 194 | |||
| 195 | @table @kbd | ||
| 196 | @item @key{RET} | ||
| 197 | List packages installed in the current generation. | ||
| 198 | @item i | ||
| 199 | Describe marked generations (display available information in a | ||
| 200 | ``generation-info'' buffer). | ||
| 201 | @end table | ||
| 202 | |||
| 203 | @node emacs Info buffer | ||
| 204 | @subsubsection ``Info'' buffer | ||
| 205 | |||
| 206 | The interface of an ``info'' buffer is similar to the interface of | ||
| 207 | @code{help-mode} (@pxref{Help Mode,,, emacs, The Emacs Editor}). | ||
| 208 | |||
| 209 | ``Info'' buffer contains some buttons (as usual you may use @key{TAB} / | ||
| 210 | @kbd{S-@key{TAB}} to move between buttons---@pxref{Mouse References,,, | ||
| 211 | emacs, The Emacs Editor}) which can be used to: | ||
| 212 | |||
| 213 | @itemize @bullet | ||
| 214 | @item (in a ``package-info'' buffer) | ||
| 215 | |||
| 216 | @itemize @minus | ||
| 217 | @item install/remove a package; | ||
| 218 | @item jump to a package location; | ||
| 219 | @item browse home page of a package; | ||
| 220 | @item describe packages from ``Inputs'' fields. | ||
| 221 | @end itemize | ||
| 222 | |||
| 223 | @item (in a ``generation-info'' buffer) | ||
| 224 | |||
| 225 | @itemize @minus | ||
| 226 | @item remove a generation; | ||
| 227 | @item list packages installed in a generation; | ||
| 228 | @item jump to a generation directory. | ||
| 229 | @end itemize | ||
| 230 | |||
| 231 | @end itemize | ||
| 232 | |||
| 233 | |||
| 234 | @node emacs Configuration | ||
| 235 | @subsection Configuration | ||
| 236 | |||
| 237 | There are many variables you can modify to change the appearance or | ||
| 238 | behavior of Emacs user interface. Some of these variables are described | ||
| 239 | in this section. Also you can use Custom Interface (@pxref{Easy | ||
| 240 | Customization,,, emacs, The Emacs Editor}) to explore/set variables (not | ||
| 241 | all) and faces. | ||
| 242 | |||
| 243 | @menu | ||
| 244 | * Guile and Build Options: emacs Build Options. Specifying how packages are built. | ||
| 245 | * Keymaps: emacs Keymaps. Configuring key bindings. | ||
| 246 | * Appearance: emacs Appearance. Settings for visual appearance. | ||
| 247 | @end menu | ||
| 248 | |||
| 249 | @node emacs Build Options | ||
| 250 | @subsubsection Guile and Build Options | ||
| 251 | |||
| 252 | @table @code | ||
| 253 | @item guix-guile-program | ||
| 254 | If you have some special needs for starting a Guile process, you may set | ||
| 255 | this variable, for example: | ||
| 256 | |||
| 257 | @example | ||
| 258 | (setq guix-guile-program '("/bin/guile" "--no-auto-compile")) | ||
| 259 | @end example | ||
| 260 | |||
| 261 | @item guix-use-substitutes | ||
| 262 | Has the same meaning as @code{--no-substitutes} option (@pxref{Invoking | ||
| 263 | guix build}). | ||
| 264 | |||
| 265 | @item guix-dry-run | ||
| 266 | Has the same meaning as @code{--dry-run} option (@pxref{Invoking guix | ||
| 267 | build}). | ||
| 268 | |||
| 269 | @end table | ||
| 270 | |||
| 271 | @node emacs Keymaps | ||
| 272 | @subsubsection Keymaps | ||
| 273 | |||
| 274 | If you want to change default key bindings, use the following keymaps | ||
| 275 | (@pxref{Init Rebinding,,, emacs, The Emacs Editor}): | ||
| 276 | |||
| 277 | @table @code | ||
| 278 | @item guix-list-mode-map | ||
| 279 | Parent keymap with general keys for ``list'' buffers. | ||
| 280 | |||
| 281 | @item guix-package-list-mode-map | ||
| 282 | Keymap with specific keys for ``package-list'' buffers. | ||
| 283 | |||
| 284 | @item guix-generation-list-mode-map | ||
| 285 | Keymap with specific keys for ``generation-list'' buffers. | ||
| 286 | |||
| 287 | @item guix-info-mode-map | ||
| 288 | Parent keymap with general keys for ``info'' buffers. | ||
| 289 | |||
| 290 | @item guix-package-info-mode-map | ||
| 291 | Keymap with specific keys for ``package-info'' buffers. | ||
| 292 | |||
| 293 | @item guix-generation-info-mode-map | ||
| 294 | Keymap with specific keys for ``generation-info'' buffers. | ||
| 295 | |||
| 296 | @end table | ||
| 297 | |||
| 298 | @node emacs Appearance | ||
| 299 | @subsubsection Appearance | ||
| 300 | |||
| 301 | You can change almost any aspect of ``list'' / ``info'' buffers using | ||
| 302 | the following variables: | ||
| 303 | |||
| 304 | @table @code | ||
| 305 | @item guix-list-column-format | ||
| 306 | @itemx guix-list-column-titles | ||
| 307 | @itemx guix-list-column-value-methods | ||
| 308 | Specify the columns, their names, what and how is displayed in ``list'' | ||
| 309 | buffers. | ||
| 310 | |||
| 311 | @item guix-info-displayed-params | ||
| 312 | @itemx guix-info-insert-methods | ||
| 313 | @itemx guix-info-ignore-empty-vals | ||
| 314 | @itemx guix-info-param-title-format | ||
| 315 | @itemx guix-info-multiline-prefix | ||
| 316 | @itemx guix-info-indent | ||
| 317 | @itemx guix-info-fill-column | ||
| 318 | @itemx guix-info-delimiter | ||
| 319 | Various settings for ``info'' buffers. | ||
| 320 | |||
| 321 | @end table | ||
diff --git a/doc/guix.texi b/doc/guix.texi index 384e2a9ced1..1f192bf0a7a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi | |||
| @@ -581,6 +581,7 @@ management tools it provides. | |||
| 581 | @menu | 581 | @menu |
| 582 | * Features:: How Guix will make your life brighter. | 582 | * Features:: How Guix will make your life brighter. |
| 583 | * Invoking guix package:: Package installation, removal, etc. | 583 | * Invoking guix package:: Package installation, removal, etc. |
| 584 | * Emacs Interface:: Package management from Emacs. | ||
| 584 | * Substitutes:: Downloading pre-built binaries. | 585 | * Substitutes:: Downloading pre-built binaries. |
| 585 | * Packages with Multiple Outputs:: Single source package, multiple outputs. | 586 | * Packages with Multiple Outputs:: Single source package, multiple outputs. |
| 586 | * Invoking guix gc:: Running the garbage collector. | 587 | * Invoking guix gc:: Running the garbage collector. |
| @@ -955,6 +956,8 @@ Finally, since @command{guix package} may actually start build | |||
| 955 | processes, it supports all the common build options that @command{guix | 956 | processes, it supports all the common build options that @command{guix |
| 956 | build} supports (@pxref{Invoking guix build, common build options}). | 957 | build} supports (@pxref{Invoking guix build, common build options}). |
| 957 | 958 | ||
| 959 | @include emacs.texi | ||
| 960 | |||
| 958 | @node Substitutes | 961 | @node Substitutes |
| 959 | @section Substitutes | 962 | @section Substitutes |
| 960 | 963 | ||
diff --git a/emacs.am b/emacs.am new file mode 100644 index 00000000000..86ae3a2c9f2 --- /dev/null +++ b/emacs.am | |||
| @@ -0,0 +1,43 @@ | |||
| 1 | # GNU Guix --- Functional package management for GNU | ||
| 2 | # Copyright © 2014 Alex Kost <alezost@gmail.com> | ||
| 3 | # | ||
| 4 | # This file is part of GNU Guix. | ||
| 5 | # | ||
| 6 | # GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | # under the terms of the GNU General Public License as published by | ||
| 8 | # the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | # your option) any later version. | ||
| 10 | # | ||
| 11 | # GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | # WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | # GNU General Public License for more details. | ||
| 15 | # | ||
| 16 | # You should have received a copy of the GNU General Public License | ||
| 17 | # along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | AUTOLOADS = emacs/guix-autoloads.el | ||
| 20 | |||
| 21 | ELFILES = \ | ||
| 22 | emacs/guix-backend.el \ | ||
| 23 | emacs/guix-base.el \ | ||
| 24 | emacs/guix-history.el \ | ||
| 25 | emacs/guix-info.el \ | ||
| 26 | emacs/guix-list.el \ | ||
| 27 | emacs/guix-utils.el \ | ||
| 28 | emacs/guix.el | ||
| 29 | |||
| 30 | dist_lisp_DATA = \ | ||
| 31 | $(ELFILES) \ | ||
| 32 | $(AUTOLOADS) | ||
| 33 | |||
| 34 | nodist_lisp_DATA = \ | ||
| 35 | emacs/guix-init.el | ||
| 36 | |||
| 37 | $(AUTOLOADS): $(ELFILES) | ||
| 38 | $(EMACS) --batch --eval \ | ||
| 39 | "(let ((backup-inhibited t) \ | ||
| 40 | (generated-autoload-file \ | ||
| 41 | (expand-file-name \"$(AUTOLOADS)\" \"$(srcdir)\"))) \ | ||
| 42 | (update-directory-autoloads \ | ||
| 43 | (expand-file-name \"emacs\" \"$(srcdir)\")))" | ||
diff --git a/emacs/guix-backend.el b/emacs/guix-backend.el new file mode 100644 index 00000000000..46d0f067781 --- /dev/null +++ b/emacs/guix-backend.el | |||
| @@ -0,0 +1,301 @@ | |||
| 1 | ;;; guix-backend.el --- Communication with Geiser | ||
| 2 | |||
| 3 | ;; Copyright © 2014 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 the code for interacting with Guile using Geiser. | ||
| 23 | |||
| 24 | ;; By default (if `guix-use-guile-server' is non-nil) 2 Geiser REPLs are | ||
| 25 | ;; started. The main one (with "guile --listen" process) is used for | ||
| 26 | ;; "interacting" with a user - for showing a progress of | ||
| 27 | ;; installing/deleting Guix packages. The second (internal) REPL is | ||
| 28 | ;; used for synchronous evaluating, e.g. when information about | ||
| 29 | ;; packages/generations should be received for a list/info buffer. | ||
| 30 | ;; | ||
| 31 | ;; This "2 REPLs concept" makes it possible to have a running process of | ||
| 32 | ;; installing/deleting packages and to continue to search/list/get info | ||
| 33 | ;; about other packages at the same time. If you prefer to use a single | ||
| 34 | ;; Guix REPL, do not try to receive any information while there is a | ||
| 35 | ;; running code in the REPL (see | ||
| 36 | ;; <https://github.com/jaor/geiser/issues/28>). | ||
| 37 | ;; | ||
| 38 | ;; If you need to use "guix.el" in another Emacs (i.e. when there is | ||
| 39 | ;; a runnig "guile --listen..." REPL somewhere), you can either change | ||
| 40 | ;; `guix-default-port' in that Emacs instance or set | ||
| 41 | ;; `guix-use-guile-server' to t. | ||
| 42 | ;; | ||
| 43 | ;; Guix REPLs (unlike the usual Geiser REPLs) are not added to | ||
| 44 | ;; `geiser-repl--repls' variable, and thus cannot be used for evaluating | ||
| 45 | ;; while editing scm-files. The only purpose of Guix REPLs is to be an | ||
| 46 | ;; intermediate between "Guix/Guile level" and "Emacs interface level". | ||
| 47 | ;; That being said you can still want to use a Guix REPL while hacking | ||
| 48 | ;; auxiliary scheme-files for "guix.el". You can just use "M-x | ||
| 49 | ;; connect-to-guile" (connect to "localhost" and `guix-default-port') to | ||
| 50 | ;; have a usual Geiser REPL with all stuff defined by "guix.el" package. | ||
| 51 | |||
| 52 | ;;; Code: | ||
| 53 | |||
| 54 | (require 'geiser-mode) | ||
| 55 | |||
| 56 | (defvar guix-load-path | ||
| 57 | (file-name-directory (or load-file-name | ||
| 58 | (locate-library "guix"))) | ||
| 59 | "Directory with scheme files for \"guix.el\" package.") | ||
| 60 | |||
| 61 | (defvar guix-helper-file | ||
| 62 | (expand-file-name "guix-helper.scm" guix-load-path) | ||
| 63 | "Auxiliary scheme file for loading.") | ||
| 64 | |||
| 65 | (defvar guix-guile-program (or geiser-guile-binary "guile") | ||
| 66 | "Name of the guile executable used for Guix REPL. | ||
| 67 | May be either a string (the name of the executable) or a list of | ||
| 68 | strings of the form: | ||
| 69 | |||
| 70 | (NAME . ARGS) | ||
| 71 | |||
| 72 | Where ARGS is a list of arguments to the guile program.") | ||
| 73 | |||
| 74 | |||
| 75 | ;;; REPL | ||
| 76 | |||
| 77 | (defgroup guix-repl nil | ||
| 78 | "Settings for Guix REPLs." | ||
| 79 | :prefix "guix-repl-" | ||
| 80 | :group 'guix) | ||
| 81 | |||
| 82 | (defcustom guix-repl-startup-time 30000 | ||
| 83 | "Time, in milliseconds, to wait for Guix REPL to startup. | ||
| 84 | Same as `geiser-repl-startup-time' but is used for Guix REPL. | ||
| 85 | If you have a slow system, try to increase this time." | ||
| 86 | :type 'integer | ||
| 87 | :group 'guix-repl) | ||
| 88 | |||
| 89 | (defcustom guix-repl-buffer-name "*Guix REPL*" | ||
| 90 | "Default name of a Geiser REPL buffer used for Guix." | ||
| 91 | :type 'string | ||
| 92 | :group 'guix-repl) | ||
| 93 | |||
| 94 | (defcustom guix-after-start-repl-hook () | ||
| 95 | "Hook called after Guix REPL is started." | ||
| 96 | :type 'hook | ||
| 97 | :group 'guix-repl) | ||
| 98 | |||
| 99 | (defcustom guix-use-guile-server t | ||
| 100 | "If non-nil, start guile with '--listen' argument. | ||
| 101 | This allows to receive information about packages using an additional | ||
| 102 | REPL while some packages are being installed/removed in the main REPL." | ||
| 103 | :type 'boolean | ||
| 104 | :group 'guix-repl) | ||
| 105 | |||
| 106 | (defcustom guix-default-port 37246 | ||
| 107 | "Default port used if `guix-use-guile-server' is non-nil." | ||
| 108 | :type 'integer | ||
| 109 | :group 'guix-repl) | ||
| 110 | |||
| 111 | (defvar guix-repl-buffer nil | ||
| 112 | "Main Geiser REPL buffer used for communicating with Guix. | ||
| 113 | This REPL is used for processing package actions and for | ||
| 114 | receiving information if `guix-use-guile-server' is nil.") | ||
| 115 | |||
| 116 | (defvar guix-internal-repl-buffer nil | ||
| 117 | "Additional Geiser REPL buffer used for communicating with Guix. | ||
| 118 | This REPL is used for receiving information only if | ||
| 119 | `guix-use-guile-server' is non-nil.") | ||
| 120 | |||
| 121 | (defvar guix-internal-repl-buffer-name "*Guix Internal REPL*" | ||
| 122 | "Default name of an internal Guix REPL buffer.") | ||
| 123 | |||
| 124 | (defun guix-get-guile-program (&optional internal) | ||
| 125 | "Return a value suitable for `geiser-guile-binary'." | ||
| 126 | (if (or internal | ||
| 127 | (not guix-use-guile-server)) | ||
| 128 | guix-guile-program | ||
| 129 | (append (if (listp guix-guile-program) | ||
| 130 | guix-guile-program | ||
| 131 | (list guix-guile-program)) | ||
| 132 | ;; Guile understands "--listen=..." but not "--listen ..." | ||
| 133 | (list (concat "--listen=" | ||
| 134 | (number-to-string guix-default-port)))))) | ||
| 135 | |||
| 136 | (defun guix-start-process-maybe () | ||
| 137 | "Start Geiser REPL configured for Guix if needed." | ||
| 138 | (guix-start-repl-maybe) | ||
| 139 | (if guix-use-guile-server | ||
| 140 | (guix-start-repl-maybe 'internal) | ||
| 141 | (setq guix-internal-repl-buffer guix-repl-buffer))) | ||
| 142 | |||
| 143 | (defun guix-start-repl-maybe (&optional internal) | ||
| 144 | "Start Guix REPL if needed. | ||
| 145 | If INTERNAL is non-nil, start an internal REPL." | ||
| 146 | (let* ((repl-var (guix-get-repl-buffer-variable internal)) | ||
| 147 | (repl (symbol-value repl-var))) | ||
| 148 | (unless (and (buffer-live-p repl) | ||
| 149 | (get-buffer-process repl)) | ||
| 150 | ;; Kill REPL buffer with a dead process | ||
| 151 | (and (buffer-live-p repl) (kill-buffer repl)) | ||
| 152 | (or internal | ||
| 153 | (message "Starting Geiser REPL for Guix ...")) | ||
| 154 | (let ((geiser-guile-binary (guix-get-guile-program internal)) | ||
| 155 | (geiser-guile-init-file (or internal guix-helper-file)) | ||
| 156 | (repl (get-buffer-create | ||
| 157 | (guix-get-repl-buffer-name internal)))) | ||
| 158 | (condition-case err | ||
| 159 | (guix-start-repl repl | ||
| 160 | (and internal | ||
| 161 | (geiser-repl--read-address | ||
| 162 | "localhost" guix-default-port))) | ||
| 163 | (text-read-only | ||
| 164 | (error (concat "Couldn't start Guix REPL. Perhaps the port %s is busy.\n" | ||
| 165 | "See buffer '%s' for details") | ||
| 166 | guix-default-port (buffer-name repl)))) | ||
| 167 | (set repl-var repl) | ||
| 168 | (unless internal | ||
| 169 | (message "Guix REPL has been started.") | ||
| 170 | (run-hooks 'guix-after-start-repl-hook)))))) | ||
| 171 | |||
| 172 | (defun guix-start-repl (buffer &optional address) | ||
| 173 | "Start Guix REPL in BUFFER. | ||
| 174 | If ADDRESS is non-nil, connect to a remote guile process using | ||
| 175 | this address (it should be defined by | ||
| 176 | `geiser-repl--read-address')." | ||
| 177 | ;; A mix of the code from `geiser-repl--start-repl' and | ||
| 178 | ;; `geiser-repl--to-repl-buffer'. | ||
| 179 | (let ((impl 'guile) | ||
| 180 | (geiser-guile-load-path (list guix-load-path)) | ||
| 181 | (geiser-repl-startup-time guix-repl-startup-time)) | ||
| 182 | (with-current-buffer buffer | ||
| 183 | (geiser-repl-mode) | ||
| 184 | (geiser-impl--set-buffer-implementation impl) | ||
| 185 | (geiser-repl--autodoc-mode -1) | ||
| 186 | (goto-char (point-max)) | ||
| 187 | (let* ((prompt-re (geiser-repl--prompt-regexp impl)) | ||
| 188 | (deb-prompt-re (geiser-repl--debugger-prompt-regexp impl)) | ||
| 189 | (prompt (geiser-con--combined-prompt prompt-re deb-prompt-re))) | ||
| 190 | (or prompt-re | ||
| 191 | (error "Oh no! Guix REPL in the buffer '%s' has not been started" | ||
| 192 | (buffer-name buffer))) | ||
| 193 | (geiser-repl--save-remote-data address) | ||
| 194 | (geiser-repl--start-scheme impl address prompt) | ||
| 195 | (geiser-repl--quit-setup) | ||
| 196 | (geiser-repl--history-setup) | ||
| 197 | (setq-local geiser-repl--repls (list buffer)) | ||
| 198 | (geiser-repl--set-this-buffer-repl buffer) | ||
| 199 | (setq geiser-repl--connection | ||
| 200 | (geiser-con--make-connection | ||
| 201 | (get-buffer-process (current-buffer)) | ||
| 202 | prompt-re | ||
| 203 | deb-prompt-re)) | ||
| 204 | (geiser-repl--startup impl address) | ||
| 205 | (geiser-repl--autodoc-mode 1) | ||
| 206 | (geiser-company--setup geiser-repl-company-p) | ||
| 207 | (add-hook 'comint-output-filter-functions | ||
| 208 | 'geiser-repl--output-filter | ||
| 209 | nil t) | ||
| 210 | (set-process-query-on-exit-flag | ||
| 211 | (get-buffer-process (current-buffer)) | ||
| 212 | geiser-repl-query-on-kill-p))))) | ||
| 213 | |||
| 214 | (defun guix-get-repl-buffer (&optional internal) | ||
| 215 | "Return Guix REPL buffer; start REPL if needed. | ||
| 216 | If INTERNAL is non-nil, return an additional internal REPL." | ||
| 217 | (guix-start-process-maybe) | ||
| 218 | (let ((repl (symbol-value (guix-get-repl-buffer-variable internal)))) | ||
| 219 | ;; If a new Geiser REPL is started, `geiser-repl--repl' variable may | ||
| 220 | ;; be set to the new value in a Guix REPL, so set it back to a | ||
| 221 | ;; proper value here. | ||
| 222 | (with-current-buffer repl | ||
| 223 | (geiser-repl--set-this-buffer-repl repl)) | ||
| 224 | repl)) | ||
| 225 | |||
| 226 | (defun guix-get-repl-buffer-variable (&optional internal) | ||
| 227 | "Return the name of a variable with a REPL buffer." | ||
| 228 | (if internal | ||
| 229 | 'guix-internal-repl-buffer | ||
| 230 | 'guix-repl-buffer)) | ||
| 231 | |||
| 232 | (defun guix-get-repl-buffer-name (&optional internal) | ||
| 233 | "Return the name of a REPL buffer." | ||
| 234 | (if internal | ||
| 235 | guix-internal-repl-buffer-name | ||
| 236 | guix-repl-buffer-name)) | ||
| 237 | |||
| 238 | (defun guix-switch-to-repl (&optional internal) | ||
| 239 | "Switch to Guix REPL. | ||
| 240 | If INTERNAL is non-nil (interactively with prefix), switch to the | ||
| 241 | additional internal REPL if it exists." | ||
| 242 | (interactive "P") | ||
| 243 | (geiser-repl--switch-to-buffer (guix-get-repl-buffer internal))) | ||
| 244 | |||
| 245 | |||
| 246 | ;;; Evaluating expressions | ||
| 247 | |||
| 248 | (defun guix-make-guile-expression (fun &rest args) | ||
| 249 | "Return string containing a guile expression for calling FUN with ARGS." | ||
| 250 | (format "(%S %s)" fun | ||
| 251 | (mapconcat | ||
| 252 | (lambda (arg) | ||
| 253 | (cond | ||
| 254 | ((null arg) "'()") | ||
| 255 | ((or (eq arg t) | ||
| 256 | ;; An ugly hack to separate 'false' from nil | ||
| 257 | (equal arg 'f) | ||
| 258 | (keywordp arg)) | ||
| 259 | (concat "#" (prin1-to-string arg t))) | ||
| 260 | ((or (symbolp arg) (listp arg)) | ||
| 261 | (concat "'" (prin1-to-string arg))) | ||
| 262 | (t (prin1-to-string arg)))) | ||
| 263 | args | ||
| 264 | " "))) | ||
| 265 | |||
| 266 | (defun guix-eval (str &optional wrap) | ||
| 267 | "Evaluate guile expression STR. | ||
| 268 | If WRAP is non-nil, wrap STR into (begin ...) form. | ||
| 269 | Return a list of strings with result values of evaluation." | ||
| 270 | (with-current-buffer (guix-get-repl-buffer 'internal) | ||
| 271 | (let* ((wrapped (if wrap (geiser-debug--wrap-region str) str)) | ||
| 272 | (code `(:eval (:scm ,wrapped))) | ||
| 273 | (ret (geiser-eval--send/wait code))) | ||
| 274 | (if (geiser-eval--retort-error ret) | ||
| 275 | (error "Error in evaluating guile expression: %s" | ||
| 276 | (geiser-eval--retort-output ret)) | ||
| 277 | (cdr (assq 'result ret)))))) | ||
| 278 | |||
| 279 | (defun guix-eval-read (str &optional wrap) | ||
| 280 | "Evaluate guile expression STR. | ||
| 281 | For the meaning of WRAP, see `guix-eval'. | ||
| 282 | Return elisp expression of the first result value of evaluation." | ||
| 283 | ;; Parsing scheme code with elisp `read' is probably not the best idea. | ||
| 284 | (read (replace-regexp-in-string | ||
| 285 | "#f\\|#<unspecified>" "nil" | ||
| 286 | (replace-regexp-in-string | ||
| 287 | "#t" "t" (car (guix-eval str wrap)))))) | ||
| 288 | |||
| 289 | (defun guix-eval-in-repl (str) | ||
| 290 | "Switch to Guix REPL and evaluate STR with guile expression there." | ||
| 291 | (let ((repl (guix-get-repl-buffer))) | ||
| 292 | (with-current-buffer repl | ||
| 293 | (delete-region (geiser-repl--last-prompt-end) (point-max)) | ||
| 294 | (goto-char (point-max)) | ||
| 295 | (insert str) | ||
| 296 | (geiser-repl--send-input)) | ||
| 297 | (geiser-repl--switch-to-buffer repl))) | ||
| 298 | |||
| 299 | (provide 'guix-backend) | ||
| 300 | |||
| 301 | ;;; guix-backend.el ends here | ||
diff --git a/emacs/guix-base.el b/emacs/guix-base.el new file mode 100644 index 00000000000..563df496cd6 --- /dev/null +++ b/emacs/guix-base.el | |||
| @@ -0,0 +1,607 @@ | |||
| 1 | ;;; guix-base.el --- Common definitions | ||
| 2 | |||
| 3 | ;; Copyright © 2014 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 some base and common definitions for guix.el | ||
| 23 | ;; package. | ||
| 24 | |||
| 25 | ;; List and info buffers have many common patterns that are defined | ||
| 26 | ;; using `guix-define-buffer-type' macro from this file. | ||
| 27 | |||
| 28 | ;;; Code: | ||
| 29 | |||
| 30 | (require 'cl-lib) | ||
| 31 | (require 'guix-backend) | ||
| 32 | (require 'guix-utils) | ||
| 33 | |||
| 34 | |||
| 35 | ;;; Profiles | ||
| 36 | |||
| 37 | (defvar guix-user-profile | ||
| 38 | (expand-file-name "~/.guix-profile") | ||
| 39 | "User profile.") | ||
| 40 | |||
| 41 | (defvar guix-default-profile | ||
| 42 | (concat (or (getenv "NIX_STATE_DIR") "/var/guix") | ||
| 43 | "/profiles/per-user/" | ||
| 44 | (getenv "USER") | ||
| 45 | "/guix-profile") | ||
| 46 | "Default Guix profile.") | ||
| 47 | |||
| 48 | (defvar guix-current-profile guix-default-profile | ||
| 49 | "Current profile.") | ||
| 50 | |||
| 51 | (defun guix-set-current-profile (path) | ||
| 52 | "Set `guix-current-profile' to PATH. | ||
| 53 | Interactively, prompt for PATH. With prefix, use | ||
| 54 | `guix-default-profile'." | ||
| 55 | (interactive | ||
| 56 | (list (if current-prefix-arg | ||
| 57 | guix-default-profile | ||
| 58 | (read-file-name "Set profile: " | ||
| 59 | (file-name-directory guix-current-profile))))) | ||
| 60 | (let ((path (directory-file-name (expand-file-name path)))) | ||
| 61 | (setq guix-current-profile | ||
| 62 | (if (string= path guix-user-profile) | ||
| 63 | guix-default-profile | ||
| 64 | path)) | ||
| 65 | (message "Current profile has been set to '%s'." | ||
| 66 | guix-current-profile))) | ||
| 67 | |||
| 68 | |||
| 69 | ;;; Parameters of the entries | ||
| 70 | |||
| 71 | (defvar guix-param-titles | ||
| 72 | '((package | ||
| 73 | (id . "ID") | ||
| 74 | (name . "Name") | ||
| 75 | (version . "Version") | ||
| 76 | (license . "License") | ||
| 77 | (synopsis . "Synopsis") | ||
| 78 | (description . "Description") | ||
| 79 | (home-url . "Home page") | ||
| 80 | (outputs . "Outputs") | ||
| 81 | (inputs . "Inputs") | ||
| 82 | (native-inputs . "Native inputs") | ||
| 83 | (propagated-inputs . "Propagated inputs") | ||
| 84 | (location . "Location") | ||
| 85 | (installed . "Installed")) | ||
| 86 | (installed | ||
| 87 | (path . "Installed path") | ||
| 88 | (dependencies . "Dependencies") | ||
| 89 | (output . "Output")) | ||
| 90 | (generation | ||
| 91 | (id . "ID") | ||
| 92 | (number . "Number") | ||
| 93 | (prev-number . "Previous number") | ||
| 94 | (path . "Path") | ||
| 95 | (time . "Time"))) | ||
| 96 | "List for defining titles of entry parameters. | ||
| 97 | Titles are used for displaying information about entries. | ||
| 98 | Each element of the list has a form: | ||
| 99 | |||
| 100 | (ENTRY-TYPE . ((PARAM . TITLE) ...))") | ||
| 101 | |||
| 102 | (defun guix-get-param-title (entry-type param) | ||
| 103 | "Return title of an ENTRY-TYPE entry parameter PARAM." | ||
| 104 | (or (guix-get-key-val guix-param-titles | ||
| 105 | entry-type param) | ||
| 106 | (prog1 (symbol-name param) | ||
| 107 | (message "Couldn't find title for '%S %S'." | ||
| 108 | entry-type param)))) | ||
| 109 | |||
| 110 | (defun guix-get-name-spec (name version &optional output) | ||
| 111 | "Return Guix package specification by its NAME, VERSION and OUTPUT." | ||
| 112 | (concat name "-" version | ||
| 113 | (when output (concat ":" output)))) | ||
| 114 | |||
| 115 | (defun guix-get-full-name (entry &optional output) | ||
| 116 | "Return name specification of the package ENTRY and OUTPUT." | ||
| 117 | (guix-get-name-spec (guix-get-key-val entry 'name) | ||
| 118 | (guix-get-key-val entry 'version) | ||
| 119 | output)) | ||
| 120 | |||
| 121 | (defun guix-get-installed-outputs (entry) | ||
| 122 | "Return list of installed outputs for the package ENTRY." | ||
| 123 | (mapcar (lambda (installed-entry) | ||
| 124 | (guix-get-key-val installed-entry 'output)) | ||
| 125 | (guix-get-key-val entry 'installed))) | ||
| 126 | |||
| 127 | (defun guix-get-entry-by-id (id entries) | ||
| 128 | "Return entry from ENTRIES by entry ID." | ||
| 129 | (cl-find-if (lambda (entry) | ||
| 130 | (equal id (guix-get-key-val entry 'id))) | ||
| 131 | entries)) | ||
| 132 | |||
| 133 | |||
| 134 | ;;; Location of the packages | ||
| 135 | |||
| 136 | (defvar guix-directory nil | ||
| 137 | "Default Guix directory. | ||
| 138 | If it is not set by a user, it is set after starting Guile REPL. | ||
| 139 | This directory is used to define location of the packages.") | ||
| 140 | |||
| 141 | (defun guix-set-directory () | ||
| 142 | "Set `guix-directory' if needed." | ||
| 143 | (or guix-directory | ||
| 144 | (setq guix-directory | ||
| 145 | (guix-eval-read "%guix-dir")))) | ||
| 146 | |||
| 147 | (add-hook 'guix-after-start-repl-hook 'guix-set-directory) | ||
| 148 | |||
| 149 | (defun guix-find-location (location) | ||
| 150 | "Go to LOCATION of a package. | ||
| 151 | LOCATION is a string of the form: | ||
| 152 | |||
| 153 | \"PATH:LINE:COLUMN\" | ||
| 154 | |||
| 155 | If PATH is relative, it is considered to be relative to | ||
| 156 | `guix-directory'." | ||
| 157 | (cl-multiple-value-bind (path line col) | ||
| 158 | (split-string location ":") | ||
| 159 | (let ((file (expand-file-name path guix-directory)) | ||
| 160 | (line (string-to-number line)) | ||
| 161 | (col (string-to-number col))) | ||
| 162 | (find-file file) | ||
| 163 | (goto-char (point-min)) | ||
| 164 | (forward-line (- line 1)) | ||
| 165 | (move-to-column col) | ||
| 166 | (recenter 1)))) | ||
| 167 | |||
| 168 | |||
| 169 | ;;; Common definitions for buffer types | ||
| 170 | |||
| 171 | (defvar-local guix-entries nil | ||
| 172 | "List of the currently displayed entries. | ||
| 173 | Each element of the list is alist with entry info of the | ||
| 174 | following form: | ||
| 175 | |||
| 176 | ((PARAM . VAL) ...) | ||
| 177 | |||
| 178 | PARAM is a name of the entry parameter. | ||
| 179 | VAL is a value of this parameter.") | ||
| 180 | (put 'guix-entries 'permanent-local t) | ||
| 181 | |||
| 182 | (defvar-local guix-search-type nil | ||
| 183 | "Type of the current search.") | ||
| 184 | (put 'guix-search-type 'permanent-local t) | ||
| 185 | |||
| 186 | (defvar-local guix-search-vals nil | ||
| 187 | "Values of the current search.") | ||
| 188 | (put 'guix-search-vals 'permanent-local t) | ||
| 189 | |||
| 190 | (defsubst guix-set-vars (entries search-type search-vals) | ||
| 191 | (setq guix-entries entries | ||
| 192 | guix-search-type search-type | ||
| 193 | guix-search-vals search-vals)) | ||
| 194 | |||
| 195 | (defmacro guix-define-buffer-type (buf-type entry-type &rest args) | ||
| 196 | "Define common stuff for BUF-TYPE buffers for displaying entries. | ||
| 197 | |||
| 198 | ENTRY-TYPE is a type of displayed entries (see | ||
| 199 | `guix-get-entries'). | ||
| 200 | |||
| 201 | In the text below TYPE means ENTRY-TYPE-BUF-TYPE. | ||
| 202 | |||
| 203 | This macro defines `guix-TYPE-mode', a custom group, several user | ||
| 204 | variables and the following functions: | ||
| 205 | |||
| 206 | - `guix-TYPE-get-params-for-receiving' | ||
| 207 | - `guix-TYPE-revert' | ||
| 208 | - `guix-TYPE-redisplay' | ||
| 209 | - `guix-TYPE-make-history-item' | ||
| 210 | - `guix-TYPE-set' | ||
| 211 | - `guix-TYPE-show' | ||
| 212 | - `guix-TYPE-get-show' | ||
| 213 | |||
| 214 | The following stuff should be defined outside this macro: | ||
| 215 | |||
| 216 | - `guix-BUF-TYPE-mode' - parent mode for the defined mode. | ||
| 217 | |||
| 218 | - `guix-BUF-TYPE-insert-entries' - function for inserting | ||
| 219 | entries in the current buffer; it is called with 2 arguments: | ||
| 220 | entries of the form of `guix-entries' and ENTRY-TYPE. | ||
| 221 | |||
| 222 | - `guix-BUF-TYPE-get-displayed-params' - function returning a | ||
| 223 | list of parameters displayed in the current buffer; it is | ||
| 224 | called with ENTRY-TYPE as argument. | ||
| 225 | |||
| 226 | - `guix-TYPE-mode-initialize' (optional) - function for | ||
| 227 | additional mode settings; it is called without arguments. | ||
| 228 | |||
| 229 | Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The | ||
| 230 | following keywords are available: | ||
| 231 | |||
| 232 | - `:required' - default value for the defined | ||
| 233 | `guix-TYPE-required-params' variable. | ||
| 234 | |||
| 235 | - `:history-size' - default value for the defined | ||
| 236 | `guix-TYPE-history-size' variable. | ||
| 237 | |||
| 238 | - `:revert' - default value for the defined | ||
| 239 | `guix-TYPE-revert-no-confirm' variable." | ||
| 240 | (let* ((entry-type-str (symbol-name entry-type)) | ||
| 241 | (buf-type-str (symbol-name buf-type)) | ||
| 242 | (Entry-type-str (capitalize entry-type-str)) | ||
| 243 | (Buf-type-str (capitalize buf-type-str)) | ||
| 244 | (entry-str (concat entry-type-str " entries")) | ||
| 245 | (buf-str (concat buf-type-str " buffer")) | ||
| 246 | (prefix (concat "guix-" entry-type-str "-" buf-type-str)) | ||
| 247 | (group (intern prefix)) | ||
| 248 | (mode-map-str (concat prefix "-mode-map")) | ||
| 249 | (mode-map (intern mode-map-str)) | ||
| 250 | (parent-mode (intern (concat "guix-" buf-type-str "-mode"))) | ||
| 251 | (mode (intern (concat prefix "-mode"))) | ||
| 252 | (mode-init-fun (intern (concat prefix "-mode-initialize"))) | ||
| 253 | (buf-name-var (intern (concat prefix "-buffer-name"))) | ||
| 254 | (revert-var (intern (concat prefix "-revert-no-confirm"))) | ||
| 255 | (revert-fun (intern (concat prefix "-revert"))) | ||
| 256 | (redisplay-fun (intern (concat prefix "-redisplay"))) | ||
| 257 | (history-var (intern (concat prefix "-history-size"))) | ||
| 258 | (history-fun (intern (concat prefix "-make-history-item"))) | ||
| 259 | (params-var (intern (concat prefix "-required-params"))) | ||
| 260 | (params-fun (intern (concat prefix "-get-params-for-receiving"))) | ||
| 261 | (set-fun (intern (concat prefix "-set"))) | ||
| 262 | (show-fun (intern (concat prefix "-show"))) | ||
| 263 | (get-show-fun (intern (concat prefix "-get-show"))) | ||
| 264 | (revert-val nil) | ||
| 265 | (history-val 20) | ||
| 266 | (params-val '(id))) | ||
| 267 | |||
| 268 | ;; Process the keyword args. | ||
| 269 | (while (keywordp (car args)) | ||
| 270 | (pcase (pop args) | ||
| 271 | (`:required (setq params-val (pop args))) | ||
| 272 | (`:history-size (setq history-val (pop args))) | ||
| 273 | (`:revert (setq revert-val (pop args))) | ||
| 274 | (_ (pop args)))) | ||
| 275 | |||
| 276 | `(progn | ||
| 277 | (defgroup ,group nil | ||
| 278 | ,(concat Buf-type-str " buffer with " entry-str ".") | ||
| 279 | :prefix ,(concat prefix "-") | ||
| 280 | :group ',(intern (concat "guix-" buf-type-str))) | ||
| 281 | |||
| 282 | (defcustom ,buf-name-var ,(format "*Guix %s %s*" | ||
| 283 | Entry-type-str Buf-type-str) | ||
| 284 | ,(concat "Default name of the " buf-str " for displaying " entry-str ".") | ||
| 285 | :type 'string | ||
| 286 | :group ',group) | ||
| 287 | |||
| 288 | (defcustom ,history-var ,history-val | ||
| 289 | ,(concat "Maximum number of items saved in the history of the " buf-str ".\n" | ||
| 290 | "If 0, the history is disabled.") | ||
| 291 | :type 'integer | ||
| 292 | :group ',group) | ||
| 293 | |||
| 294 | (defcustom ,revert-var ,revert-val | ||
| 295 | ,(concat "If non-nil, do not ask to confirm for reverting the " buf-str ".") | ||
| 296 | :type 'boolean | ||
| 297 | :group ',group) | ||
| 298 | |||
| 299 | (defvar ,params-var ',params-val | ||
| 300 | ,(concat "List of required " entry-type-str " parameters.\n\n" | ||
| 301 | "Displayed parameters and parameters from this list are received\n" | ||
| 302 | "for each " entry-type-str ".\n\n" | ||
| 303 | "May be a special value `all', in which case all supported\n" | ||
| 304 | "parameters are received (this may be very slow for a big number\n" | ||
| 305 | "of entries).\n\n" | ||
| 306 | "Do not remove `id' from this list as it is required for\n" | ||
| 307 | "identifying an entry.")) | ||
| 308 | |||
| 309 | (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str) | ||
| 310 | ,(concat "Major mode for displaying information about " entry-str ".\n\n" | ||
| 311 | "\\{" mode-map-str "}") | ||
| 312 | (setq-local revert-buffer-function ',revert-fun) | ||
| 313 | (setq-local guix-history-size ,history-var) | ||
| 314 | (and (fboundp ',mode-init-fun) (,mode-init-fun))) | ||
| 315 | |||
| 316 | (let ((map ,mode-map)) | ||
| 317 | (define-key map (kbd "l") 'guix-history-back) | ||
| 318 | (define-key map (kbd "r") 'guix-history-forward) | ||
| 319 | (define-key map (kbd "g") 'revert-buffer) | ||
| 320 | (define-key map (kbd "R") ',redisplay-fun) | ||
| 321 | (define-key map (kbd "C-c C-z") 'guix-switch-to-repl)) | ||
| 322 | |||
| 323 | (defun ,params-fun () | ||
| 324 | ,(concat "Return " entry-type-str " parameters that should be received.") | ||
| 325 | (unless (equal ,params-var 'all) | ||
| 326 | (cl-union ,params-var | ||
| 327 | (,(intern (concat "guix-" buf-type-str "-get-displayed-params")) | ||
| 328 | ',entry-type)))) | ||
| 329 | |||
| 330 | (defun ,revert-fun (_ignore-auto noconfirm) | ||
| 331 | "Update information in the current buffer. | ||
| 332 | The function is suitable for `revert-buffer-function'. | ||
| 333 | See `revert-buffer' for the meaning of NOCONFIRM." | ||
| 334 | (when (or ,revert-var | ||
| 335 | noconfirm | ||
| 336 | (y-or-n-p "Update current information? ")) | ||
| 337 | (let ((entries (guix-get-entries ',entry-type guix-search-type | ||
| 338 | guix-search-vals (,params-fun)))) | ||
| 339 | (,set-fun entries guix-search-type guix-search-vals t)))) | ||
| 340 | |||
| 341 | (defun ,redisplay-fun () | ||
| 342 | "Redisplay current information. | ||
| 343 | This function will not update the information, use | ||
| 344 | \"\\[revert-buffer]\" if you want the full update." | ||
| 345 | (interactive) | ||
| 346 | (,show-fun guix-entries) | ||
| 347 | (guix-result-message guix-entries ',entry-type | ||
| 348 | guix-search-type guix-search-vals)) | ||
| 349 | |||
| 350 | (defun ,history-fun () | ||
| 351 | "Make and return a history item for the current buffer." | ||
| 352 | (list (lambda (entries search-type search-vals) | ||
| 353 | (,show-fun entries) | ||
| 354 | (guix-set-vars entries search-type search-vals) | ||
| 355 | (guix-result-message entries ',entry-type | ||
| 356 | search-type search-vals)) | ||
| 357 | guix-entries guix-search-type guix-search-vals)) | ||
| 358 | |||
| 359 | (defun ,set-fun (entries search-type search-vals &optional history-replace) | ||
| 360 | ,(concat "Set up the " buf-str " for displaying " entry-str ".\n\n" | ||
| 361 | "Display ENTRIES, set variables and make history item.\n\n" | ||
| 362 | "ENTRIES should have a form of `guix-entries'.\n\n" | ||
| 363 | "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n" | ||
| 364 | "SEARCH-VALS.\n\n" | ||
| 365 | "If HISTORY-REPLACE is non-nil, replace current history item,\n" | ||
| 366 | "otherwise add the new one.") | ||
| 367 | (when entries | ||
| 368 | (let ((buf (if (eq major-mode ',mode) | ||
| 369 | (current-buffer) | ||
| 370 | (get-buffer-create ,buf-name-var)))) | ||
| 371 | (with-current-buffer buf | ||
| 372 | (,show-fun entries) | ||
| 373 | (guix-set-vars entries search-type search-vals) | ||
| 374 | (funcall (if history-replace | ||
| 375 | #'guix-history-replace | ||
| 376 | #'guix-history-add) | ||
| 377 | (,history-fun))) | ||
| 378 | (pop-to-buffer buf | ||
| 379 | '((display-buffer-reuse-window | ||
| 380 | display-buffer-same-window))))) | ||
| 381 | (guix-result-message entries ',entry-type | ||
| 382 | search-type search-vals)) | ||
| 383 | |||
| 384 | (defun ,show-fun (entries) | ||
| 385 | ,(concat "Display " entry-type-str " ENTRIES in the current " buf-str ".") | ||
| 386 | (let ((inhibit-read-only t)) | ||
| 387 | (erase-buffer) | ||
| 388 | (,mode) | ||
| 389 | (,(intern (concat "guix-" buf-type-str "-insert-entries")) | ||
| 390 | entries ',entry-type) | ||
| 391 | (goto-char (point-min)))) | ||
| 392 | |||
| 393 | (defun ,get-show-fun (search-type &rest search-vals) | ||
| 394 | ,(concat "Search for " entry-str " and show results in the " buf-str ".\n" | ||
| 395 | "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n" | ||
| 396 | "SEARCH-VALS.") | ||
| 397 | (let ((entries (guix-get-entries ',entry-type search-type | ||
| 398 | search-vals (,params-fun)))) | ||
| 399 | (,set-fun entries search-type search-vals)))))) | ||
| 400 | |||
| 401 | (put 'guix-define-buffer-type 'lisp-indent-function 'defun) | ||
| 402 | |||
| 403 | |||
| 404 | ;;; Messages | ||
| 405 | |||
| 406 | (defvar guix-messages | ||
| 407 | '((package | ||
| 408 | (id | ||
| 409 | (0 "Packages not found.") | ||
| 410 | (1 "") | ||
| 411 | (many "%d packages." count)) | ||
| 412 | (name | ||
| 413 | (0 "The package '%s' not found." val) | ||
| 414 | (1 "A single package with name '%s'." val) | ||
| 415 | (many "%d packages with '%s' name." count val)) | ||
| 416 | (regexp | ||
| 417 | (0 "No packages matching '%s'." val) | ||
| 418 | (1 "A single package matching '%s'." val) | ||
| 419 | (many "%d packages matching '%s'." count val)) | ||
| 420 | (all-available | ||
| 421 | (0 "No packages are available for some reason.") | ||
| 422 | (1 "A single available package (that's strange).") | ||
| 423 | (many "%d available packages." count)) | ||
| 424 | (newest-available | ||
| 425 | (0 "No packages are available for some reason.") | ||
| 426 | (1 "A single newest available package (that's strange).") | ||
| 427 | (many "%d newest available packages." count)) | ||
| 428 | (installed | ||
| 429 | (0 "No installed packages.") | ||
| 430 | (1 "A single installed package.") | ||
| 431 | (many "%d installed packages." count)) | ||
| 432 | (obsolete | ||
| 433 | (0 "No obsolete packages.") | ||
| 434 | (1 "A single obsolete package.") | ||
| 435 | (many "%d obsolete packages." count)) | ||
| 436 | (generation | ||
| 437 | (0 "No packages installed in generation %d." val) | ||
| 438 | (1 "A single package installed in generation %d." val) | ||
| 439 | (many "%d packages installed in generation %d." count val))) | ||
| 440 | (generation | ||
| 441 | (id | ||
| 442 | (0 "Generations not found.") | ||
| 443 | (1 "") | ||
| 444 | (many "%d generations." count)) | ||
| 445 | (last | ||
| 446 | (0 "No available generations.") | ||
| 447 | (1 "The last generation.") | ||
| 448 | (many "%d last generations." count)) | ||
| 449 | (all | ||
| 450 | (0 "No available generations.") | ||
| 451 | (1 "A single available generation.") | ||
| 452 | (many "%d available generations." count))))) | ||
| 453 | |||
| 454 | (defun guix-result-message (entries entry-type search-type search-vals) | ||
| 455 | "Display an appropriate message after displaying ENTRIES." | ||
| 456 | (let* ((val (car search-vals)) | ||
| 457 | (count (length entries)) | ||
| 458 | (count-key (if (> count 1) 'many count)) | ||
| 459 | (msg-spec (guix-get-key-val guix-messages | ||
| 460 | entry-type search-type count-key)) | ||
| 461 | (format (car msg-spec)) | ||
| 462 | (args (cdr msg-spec))) | ||
| 463 | (mapc (lambda (subst) | ||
| 464 | (setq args (cl-substitute (car subst) (cdr subst) args))) | ||
| 465 | (list (cons count 'count) | ||
| 466 | (cons val 'val))) | ||
| 467 | (apply #'message format args))) | ||
| 468 | |||
| 469 | |||
| 470 | ;;; Getting info about packages and generations | ||
| 471 | |||
| 472 | (defun guix-get-entries (entry-type search-type search-vals &optional params) | ||
| 473 | "Search for entries of ENTRY-TYPE. | ||
| 474 | |||
| 475 | Call an appropriate scheme function and return a list of the | ||
| 476 | form of `guix-entries'. | ||
| 477 | |||
| 478 | ENTRY-TYPE should be one of the following symbols: `package' or | ||
| 479 | `generation'. | ||
| 480 | |||
| 481 | SEARCH-TYPE may be one of the following symbols: | ||
| 482 | |||
| 483 | - If ENTRY-TYPE is `package': `id', `name', `regexp', | ||
| 484 | `all-available', `newest-available', `installed', `obsolete', | ||
| 485 | `generation'. | ||
| 486 | |||
| 487 | - If ENTRY-TYPE is `generation': `id', `last', `all'. | ||
| 488 | |||
| 489 | PARAMS is a list of parameters for receiving. If nil, get | ||
| 490 | information with all available parameters." | ||
| 491 | (guix-eval-read (guix-make-guile-expression | ||
| 492 | 'get-entries | ||
| 493 | guix-current-profile params | ||
| 494 | entry-type search-type search-vals))) | ||
| 495 | |||
| 496 | |||
| 497 | ;;; Actions on packages and generations | ||
| 498 | |||
| 499 | (defcustom guix-operation-confirm t | ||
| 500 | "If nil, do not prompt to confirm an operation." | ||
| 501 | :type 'boolean | ||
| 502 | :group 'guix) | ||
| 503 | |||
| 504 | (defcustom guix-use-substitutes t | ||
| 505 | "If non-nil, use substitutes for the Guix packages." | ||
| 506 | :type 'boolean | ||
| 507 | :group 'guix) | ||
| 508 | |||
| 509 | (defvar guix-dry-run nil | ||
| 510 | "If non-nil, do not perform the real actions, just simulate.") | ||
| 511 | |||
| 512 | (defvar guix-temp-buffer-name " *Guix temp*" | ||
| 513 | "Name of a buffer used for displaying info before executing operation.") | ||
| 514 | |||
| 515 | (defun guix-process-package-actions (&rest actions) | ||
| 516 | "Process package ACTIONS. | ||
| 517 | Each action is a list of the form: | ||
| 518 | |||
| 519 | (ACTION-TYPE PACKAGE-SPEC ...) | ||
| 520 | |||
| 521 | ACTION-TYPE is one of the following symbols: `install', | ||
| 522 | `upgrade', `remove'/`delete'. | ||
| 523 | PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." | ||
| 524 | (let (install upgrade remove) | ||
| 525 | (mapc (lambda (action) | ||
| 526 | (let ((action-type (car action)) | ||
| 527 | (specs (cdr action))) | ||
| 528 | (cl-case action-type | ||
| 529 | (install (setq install (append install specs))) | ||
| 530 | (upgrade (setq upgrade (append upgrade specs))) | ||
| 531 | ((remove delete) (setq remove (append remove specs)))))) | ||
| 532 | actions) | ||
| 533 | (when (guix-continue-package-operation-p | ||
| 534 | :install install :upgrade upgrade :remove remove) | ||
| 535 | (guix-eval-in-repl | ||
| 536 | (guix-make-guile-expression | ||
| 537 | 'process-package-actions guix-current-profile | ||
| 538 | :install install :upgrade upgrade :remove remove | ||
| 539 | :use-substitutes? (or guix-use-substitutes 'f) | ||
| 540 | :dry-run? (or guix-dry-run 'f)))))) | ||
| 541 | |||
| 542 | (cl-defun guix-continue-package-operation-p (&key install upgrade remove) | ||
| 543 | "Return non-nil if a package operation should be continued. | ||
| 544 | Ask a user if needed (see `guix-operation-confirm'). | ||
| 545 | INSTALL, UPGRADE, REMOVE are 'package action specifications'. | ||
| 546 | See `guix-process-package-actions' for details." | ||
| 547 | (or (null guix-operation-confirm) | ||
| 548 | (let* ((entries (guix-get-entries | ||
| 549 | 'package 'id | ||
| 550 | (list (append (mapcar #'car install) | ||
| 551 | (mapcar #'car upgrade) | ||
| 552 | (mapcar #'car remove))) | ||
| 553 | '(id name version location))) | ||
| 554 | (install-strings (guix-get-package-strings install entries)) | ||
| 555 | (upgrade-strings (guix-get-package-strings upgrade entries)) | ||
| 556 | (remove-strings (guix-get-package-strings remove entries))) | ||
| 557 | (if (or install-strings upgrade-strings remove-strings) | ||
| 558 | (let ((buf (get-buffer-create guix-temp-buffer-name))) | ||
| 559 | (with-current-buffer buf | ||
| 560 | (setq-local cursor-type nil) | ||
| 561 | (setq buffer-read-only nil) | ||
| 562 | (erase-buffer) | ||
| 563 | (guix-insert-package-strings install-strings "install") | ||
| 564 | (guix-insert-package-strings upgrade-strings "upgrade") | ||
| 565 | (guix-insert-package-strings remove-strings "remove") | ||
| 566 | (let ((win (temp-buffer-window-show | ||
| 567 | buf | ||
| 568 | '((display-buffer-reuse-window | ||
| 569 | display-buffer-at-bottom) | ||
| 570 | (window-height . fit-window-to-buffer))))) | ||
| 571 | (prog1 (y-or-n-p "Continue operation? ") | ||
| 572 | (quit-window nil win))))) | ||
| 573 | (message "Nothing to be done. If the REPL was restarted, information is not up-to-date.") | ||
| 574 | nil)))) | ||
| 575 | |||
| 576 | (defun guix-get-package-strings (specs entries) | ||
| 577 | "Return short package descriptions for performing package actions. | ||
| 578 | See `guix-process-package-actions' for the meaning of SPECS. | ||
| 579 | ENTRIES is a list of package entries to get info about packages." | ||
| 580 | (delq nil | ||
| 581 | (mapcar | ||
| 582 | (lambda (spec) | ||
| 583 | (let* ((id (car spec)) | ||
| 584 | (outputs (cdr spec)) | ||
| 585 | (entry (guix-get-entry-by-id id entries))) | ||
| 586 | (when entry | ||
| 587 | (let ((location (guix-get-key-val entry 'location))) | ||
| 588 | (concat (guix-get-full-name entry) | ||
| 589 | (when outputs | ||
| 590 | (concat ":" | ||
| 591 | (mapconcat #'identity outputs ","))) | ||
| 592 | (when location | ||
| 593 | (concat "\t(" location ")"))))))) | ||
| 594 | specs))) | ||
| 595 | |||
| 596 | (defun guix-insert-package-strings (strings action) | ||
| 597 | "Insert information STRINGS at point for performing package ACTION." | ||
| 598 | (when strings | ||
| 599 | (insert "Package(s) to " (guix-get-string action 'bold) ":\n") | ||
| 600 | (mapc (lambda (str) | ||
| 601 | (insert " " str "\n")) | ||
| 602 | strings) | ||
| 603 | (insert "\n"))) | ||
| 604 | |||
| 605 | (provide 'guix-base) | ||
| 606 | |||
| 607 | ;;; guix-base.el ends here | ||
diff --git a/emacs/guix-helper.scm.in b/emacs/guix-helper.scm.in new file mode 100644 index 00000000000..554d55119f1 --- /dev/null +++ b/emacs/guix-helper.scm.in | |||
| @@ -0,0 +1,64 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | ;;; Commentary: | ||
| 20 | |||
| 21 | ;; This is an auxiliary file for the Emacs UI. It is used to add Guix | ||
| 22 | ;; directories to path variables and to load the main code. | ||
| 23 | |||
| 24 | ;;; Code: | ||
| 25 | |||
| 26 | (use-modules (ice-9 regex) | ||
| 27 | (srfi srfi-26)) | ||
| 28 | |||
| 29 | (define %guix-dir) | ||
| 30 | |||
| 31 | ;; The code is taken from ‘guix’ executable script | ||
| 32 | (define (set-paths!) | ||
| 33 | (define-syntax-rule (push! elt v) (set! v (cons elt v))) | ||
| 34 | |||
| 35 | (define config-lookup | ||
| 36 | (let ((config '(("prefix" . "@prefix@") | ||
| 37 | ("guilemoduledir" . "@guilemoduledir@"))) | ||
| 38 | (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}"))) | ||
| 39 | (define (expand-var-ref match) | ||
| 40 | (lookup (match:substring match 1))) | ||
| 41 | (define (expand str) | ||
| 42 | (regexp-substitute/global #f var-ref-regexp str | ||
| 43 | 'pre expand-var-ref 'post)) | ||
| 44 | (define (lookup name) | ||
| 45 | (expand (assoc-ref config name))) | ||
| 46 | lookup)) | ||
| 47 | |||
| 48 | (let ((module-dir (config-lookup "guilemoduledir")) | ||
| 49 | (updates-dir (and=> (or (getenv "XDG_CONFIG_HOME") | ||
| 50 | (and=> (getenv "HOME") | ||
| 51 | (cut string-append <> "/.config"))) | ||
| 52 | (cut string-append <> "/guix/latest")))) | ||
| 53 | (push! module-dir %load-compiled-path) | ||
| 54 | (if (and updates-dir (file-exists? updates-dir)) | ||
| 55 | (begin | ||
| 56 | (set! %guix-dir updates-dir) | ||
| 57 | (push! updates-dir %load-path) | ||
| 58 | (push! updates-dir %load-compiled-path)) | ||
| 59 | (set! %guix-dir module-dir)))) | ||
| 60 | |||
| 61 | (set-paths!) | ||
| 62 | |||
| 63 | (load-from-path "guix-main") | ||
| 64 | |||
diff --git a/emacs/guix-history.el b/emacs/guix-history.el new file mode 100644 index 00000000000..5d301a689e8 --- /dev/null +++ b/emacs/guix-history.el | |||
| @@ -0,0 +1,92 @@ | |||
| 1 | ;;; guix-history.el --- History of buffer information | ||
| 2 | |||
| 3 | ;; Copyright © 2014 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 support for history of buffers similar to the | ||
| 23 | ;; history of a `help-mode' buffer. | ||
| 24 | |||
| 25 | ;;; Code: | ||
| 26 | |||
| 27 | (require 'cl-macs) | ||
| 28 | |||
| 29 | (defvar-local guix-history-stack-item nil | ||
| 30 | "Current item of the history. | ||
| 31 | A list of the form (FUNCTION [ARGS ...]). | ||
| 32 | The item is used by calling (apply FUNCTION ARGS).") | ||
| 33 | (put 'guix-history-stack-item 'permanent-local t) | ||
| 34 | |||
| 35 | (defvar-local guix-history-back-stack nil | ||
| 36 | "Stack (list) of visited items. | ||
| 37 | Each element of the list has a form of `guix-history-stack-item'.") | ||
| 38 | (put 'guix-history-back-stack 'permanent-local t) | ||
| 39 | |||
| 40 | (defvar-local guix-history-forward-stack nil | ||
| 41 | "Stack (list) of items visited with `guix-history-back'. | ||
| 42 | Each element of the list has a form of `guix-history-stack-item'.") | ||
| 43 | (put 'guix-history-forward-stack 'permanent-local t) | ||
| 44 | |||
| 45 | (defvar guix-history-size 0 | ||
| 46 | "Maximum number of items saved in history. | ||
| 47 | If 0, the history is disabled.") | ||
| 48 | |||
| 49 | (defun guix-history-add (item) | ||
| 50 | "Add ITEM to history." | ||
| 51 | (and guix-history-stack-item | ||
| 52 | (push guix-history-stack-item guix-history-back-stack)) | ||
| 53 | (setq guix-history-forward-stack nil | ||
| 54 | guix-history-stack-item item) | ||
| 55 | (when (>= (length guix-history-back-stack) | ||
| 56 | guix-history-size) | ||
| 57 | (setq guix-history-back-stack | ||
| 58 | (cl-loop for elt in guix-history-back-stack | ||
| 59 | for i from 1 to guix-history-size | ||
| 60 | collect elt)))) | ||
| 61 | |||
| 62 | (defun guix-history-replace (item) | ||
| 63 | "Replace current item in history with ITEM." | ||
| 64 | (setq guix-history-stack-item item)) | ||
| 65 | |||
| 66 | (defun guix-history-goto (item) | ||
| 67 | "Go to the ITEM of history. | ||
| 68 | ITEM should have the form of `guix-history-stack-item'." | ||
| 69 | (or (listp item) | ||
| 70 | (error "Wrong value of history element")) | ||
| 71 | (setq guix-history-stack-item item) | ||
| 72 | (apply (car item) (cdr item))) | ||
| 73 | |||
| 74 | (defun guix-history-back () | ||
| 75 | "Go back to the previous element of history in the current buffer." | ||
| 76 | (interactive) | ||
| 77 | (or guix-history-back-stack | ||
| 78 | (user-error "No previous element in history")) | ||
| 79 | (push guix-history-stack-item guix-history-forward-stack) | ||
| 80 | (guix-history-goto (pop guix-history-back-stack))) | ||
| 81 | |||
| 82 | (defun guix-history-forward () | ||
| 83 | "Go forward to the next element of history in the current buffer." | ||
| 84 | (interactive) | ||
| 85 | (or guix-history-forward-stack | ||
| 86 | (user-error "No next element in history")) | ||
| 87 | (push guix-history-stack-item guix-history-back-stack) | ||
| 88 | (guix-history-goto (pop guix-history-forward-stack))) | ||
| 89 | |||
| 90 | (provide 'guix-history) | ||
| 91 | |||
| 92 | ;;; guix-history.el ends here | ||
diff --git a/emacs/guix-info.el b/emacs/guix-info.el new file mode 100644 index 00000000000..687a15eefa5 --- /dev/null +++ b/emacs/guix-info.el | |||
| @@ -0,0 +1,556 @@ | |||
| 1 | ;;; guix-info.el --- Info buffers for displaying entries | ||
| 2 | |||
| 3 | ;; Copyright © 2014 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 a help-like buffer for displaying information | ||
| 23 | ;; about Guix packages and generations. | ||
| 24 | |||
| 25 | ;;; Code: | ||
| 26 | |||
| 27 | (require 'guix-history) | ||
| 28 | (require 'guix-base) | ||
| 29 | (require 'guix-utils) | ||
| 30 | |||
| 31 | (defgroup guix-info nil | ||
| 32 | "General settings for info buffers." | ||
| 33 | :prefix "guix-info-" | ||
| 34 | :group 'guix) | ||
| 35 | |||
| 36 | (defface guix-info-param-title | ||
| 37 | '((t :inherit font-lock-type-face)) | ||
| 38 | "Face used for titles of parameters." | ||
| 39 | :group 'guix-info) | ||
| 40 | |||
| 41 | (defface guix-info-file-path | ||
| 42 | '((t :inherit link)) | ||
| 43 | "Face used for file paths." | ||
| 44 | :group 'guix-info) | ||
| 45 | |||
| 46 | (defface guix-info-url | ||
| 47 | '((t :inherit link)) | ||
| 48 | "Face used for URLs." | ||
| 49 | :group 'guix-info) | ||
| 50 | |||
| 51 | (defface guix-info-time | ||
| 52 | '((t :inherit font-lock-constant-face)) | ||
| 53 | "Face used for timestamps." | ||
| 54 | :group 'guix-info) | ||
| 55 | |||
| 56 | (defface guix-info-action-button | ||
| 57 | '((((type x w32 ns) (class color)) | ||
| 58 | :box (:line-width 2 :style released-button) | ||
| 59 | :background "lightgrey" :foreground "black") | ||
| 60 | (t :inherit button)) | ||
| 61 | "Face used for action buttons." | ||
| 62 | :group 'guix-info) | ||
| 63 | |||
| 64 | (defface guix-info-action-button-mouse | ||
| 65 | '((((type x w32 ns) (class color)) | ||
| 66 | :box (:line-width 2 :style released-button) | ||
| 67 | :background "grey90" :foreground "black") | ||
| 68 | (t :inherit highlight)) | ||
| 69 | "Mouse face used for action buttons." | ||
| 70 | :group 'guix-info) | ||
| 71 | |||
| 72 | (defcustom guix-info-ignore-empty-vals nil | ||
| 73 | "If non-nil, do not display parameters with nil values." | ||
| 74 | :type 'boolean | ||
| 75 | :group 'guix-info) | ||
| 76 | |||
| 77 | (defvar guix-info-param-title-format "%-18s: " | ||
| 78 | "String used to format a title of a parameter. | ||
| 79 | It should be a '%s'-sequence. After inserting a title formatted | ||
| 80 | with this string, a value of the parameter is inserted. | ||
| 81 | This string is used by `guix-info-insert-title-default'.") | ||
| 82 | |||
| 83 | (defvar guix-info-multiline-prefix (make-string 20 ?\s) | ||
| 84 | "String used to format multi-line parameter values. | ||
| 85 | If a value occupies more than one line, this string is inserted | ||
| 86 | in the beginning of each line after the first one. | ||
| 87 | This string is used by `guix-info-insert-val-default'.") | ||
| 88 | |||
| 89 | (defvar guix-info-indent 2 | ||
| 90 | "Number of spaces used to indent various parts of inserted text.") | ||
| 91 | |||
| 92 | (defvar guix-info-fill-column 60 | ||
| 93 | "Column used for filling (word wrapping) parameters with long lines. | ||
| 94 | If a value is not multi-line and it occupies more than this | ||
| 95 | number of characters, it will be split into several lines.") | ||
| 96 | |||
| 97 | (defvar guix-info-delimiter "\n\f\n" | ||
| 98 | "String used to separate entries.") | ||
| 99 | |||
| 100 | (defvar guix-info-insert-methods | ||
| 101 | '((package | ||
| 102 | (name guix-package-info-name) | ||
| 103 | (version guix-package-info-version) | ||
| 104 | (license guix-package-info-license) | ||
| 105 | (synopsis guix-package-info-synopsis) | ||
| 106 | (description guix-package-info-insert-description | ||
| 107 | guix-info-insert-title-simple) | ||
| 108 | (outputs guix-package-info-insert-outputs | ||
| 109 | guix-info-insert-title-simple) | ||
| 110 | (home-url guix-info-insert-url) | ||
| 111 | (inputs guix-package-info-insert-inputs) | ||
| 112 | (native-inputs guix-package-info-insert-native-inputs) | ||
| 113 | (propagated-inputs guix-package-info-insert-propagated-inputs) | ||
| 114 | (location guix-package-info-insert-location)) | ||
| 115 | (installed | ||
| 116 | (path guix-package-info-insert-output-path | ||
| 117 | guix-info-insert-title-simple) | ||
| 118 | (dependencies guix-package-info-insert-output-dependencies | ||
| 119 | guix-info-insert-title-simple)) | ||
| 120 | (generation | ||
| 121 | (number guix-generation-info-insert-number) | ||
| 122 | (path guix-info-insert-file-path) | ||
| 123 | (time guix-info-insert-time))) | ||
| 124 | "Methods for inserting parameter values. | ||
| 125 | Each element of the list should have a form: | ||
| 126 | |||
| 127 | (ENTRY-TYPE . ((PARAM INSERT-VALUE [INSERT-TITLE]) ...)) | ||
| 128 | |||
| 129 | INSERT-VALUE may be either nil, a face name or a function. If it | ||
| 130 | is nil or a face, `guix-info-insert-val-default' function is | ||
| 131 | called with parameter value and INSERT-VALUE as arguments. If it | ||
| 132 | is a function, this function is called with parameter value and | ||
| 133 | entry info (alist of parameters and their values) as arguments. | ||
| 134 | |||
| 135 | INSERT-TITLE may be either nil, a face name or a function. If it | ||
| 136 | is nil or a face, `guix-info-insert-title-default' function is | ||
| 137 | called with parameter title and INSERT-TITLE as arguments. If it | ||
| 138 | is a function, this function is called with parameter title as | ||
| 139 | argument.") | ||
| 140 | |||
| 141 | (defvar guix-info-displayed-params | ||
| 142 | '((package name version synopsis outputs location home-url | ||
| 143 | license inputs native-inputs propagated-inputs description) | ||
| 144 | (installed path dependencies) | ||
| 145 | (generation number prev-number time path)) | ||
| 146 | "List of displayed entry parameters. | ||
| 147 | Each element of the list should have a form: | ||
| 148 | |||
| 149 | (ENTRY-TYPE . (PARAM ...)) | ||
| 150 | |||
| 151 | The order of displayed parameters is the same as in this list.") | ||
| 152 | |||
| 153 | (defun guix-info-get-insert-methods (entry-type param) | ||
| 154 | "Return list of insert methods for parameter PARAM of ENTRY-TYPE. | ||
| 155 | See `guix-info-insert-methods' for details." | ||
| 156 | (guix-get-key-val guix-info-insert-methods | ||
| 157 | entry-type param)) | ||
| 158 | |||
| 159 | (defun guix-info-get-displayed-params (entry-type) | ||
| 160 | "Return parameters of ENTRY-TYPE that should be displayed." | ||
| 161 | (guix-get-key-val guix-info-displayed-params | ||
| 162 | entry-type)) | ||
| 163 | |||
| 164 | (defun guix-info-get-indent (&optional level) | ||
| 165 | "Return `guix-info-indent' \"multiplied\" by LEVEL spaces. | ||
| 166 | LEVEL is 1 by default." | ||
| 167 | (make-string (* guix-info-indent (or level 1)) ?\s)) | ||
| 168 | |||
| 169 | (defun guix-info-insert-indent (&optional level) | ||
| 170 | "Insert `guix-info-indent' spaces LEVEL times (1 by default)." | ||
| 171 | (insert (guix-info-get-indent level))) | ||
| 172 | |||
| 173 | (defun guix-info-insert-entries (entries entry-type) | ||
| 174 | "Display ENTRIES of ENTRY-TYPE in the current info buffer. | ||
| 175 | ENTRIES should have a form of `guix-entries'." | ||
| 176 | (guix-mapinsert (lambda (entry) | ||
| 177 | (guix-info-insert-entry entry entry-type)) | ||
| 178 | entries | ||
| 179 | guix-info-delimiter)) | ||
| 180 | |||
| 181 | (defun guix-info-insert-entry (entry entry-type &optional indent-level) | ||
| 182 | "Insert ENTRY of ENTRY-TYPE into the current info buffer. | ||
| 183 | If INDENT-LEVEL is non-nil, indent displayed information by this | ||
| 184 | number of `guix-info-indent' spaces." | ||
| 185 | (let ((region-beg (point))) | ||
| 186 | (mapc (lambda (param) | ||
| 187 | (guix-info-insert-param param entry entry-type)) | ||
| 188 | (guix-info-get-displayed-params entry-type)) | ||
| 189 | (when indent-level | ||
| 190 | (indent-rigidly region-beg (point) | ||
| 191 | (* indent-level guix-info-indent))))) | ||
| 192 | |||
| 193 | (defun guix-info-insert-param (param entry entry-type) | ||
| 194 | "Insert title and value of a PARAM at point. | ||
| 195 | ENTRY is alist with parameters and their values. | ||
| 196 | ENTRY-TYPE is a type of ENTRY." | ||
| 197 | (let ((val (guix-get-key-val entry param))) | ||
| 198 | (unless (and guix-info-ignore-empty-vals (null val)) | ||
| 199 | (let* ((title (guix-get-param-title entry-type param)) | ||
| 200 | (insert-methods (guix-info-get-insert-methods entry-type param)) | ||
| 201 | (val-method (car insert-methods)) | ||
| 202 | (title-method (cadr insert-methods))) | ||
| 203 | (guix-info-method-funcall title title-method | ||
| 204 | #'guix-info-insert-title-default) | ||
| 205 | (guix-info-method-funcall val val-method | ||
| 206 | #'guix-info-insert-val-default | ||
| 207 | entry) | ||
| 208 | (insert "\n"))))) | ||
| 209 | |||
| 210 | (defun guix-info-method-funcall (val method default-fun &rest args) | ||
| 211 | "Call METHOD or DEFAULT-FUN. | ||
| 212 | |||
| 213 | If METHOD is a function and VAL is non-nil, call this | ||
| 214 | function by applying it to VAL and ARGS. | ||
| 215 | |||
| 216 | If METHOD is a face, propertize inserted VAL with this face." | ||
| 217 | (cond ((or (null method) | ||
| 218 | (facep method)) | ||
| 219 | (funcall default-fun val method)) | ||
| 220 | ((functionp method) | ||
| 221 | (apply method val args)) | ||
| 222 | (t (error "Unknown method '%S'" method)))) | ||
| 223 | |||
| 224 | (defun guix-info-insert-title-default (title &optional face format) | ||
| 225 | "Insert TITLE formatted with `guix-info-param-title-format' at point." | ||
| 226 | (guix-format-insert title | ||
| 227 | (or face 'guix-info-param-title) | ||
| 228 | (or format guix-info-param-title-format))) | ||
| 229 | |||
| 230 | (defun guix-info-insert-title-simple (title &optional face) | ||
| 231 | "Insert TITLE at point." | ||
| 232 | (guix-info-insert-title-default title face "%s:")) | ||
| 233 | |||
| 234 | (defun guix-info-insert-val-default (val &optional face) | ||
| 235 | "Format and insert parameter value VAL at point. | ||
| 236 | |||
| 237 | This function is intended to be called after | ||
| 238 | `guix-info-insert-title-default'. | ||
| 239 | |||
| 240 | If VAL is a one-line string longer than `guix-info-fill-column', | ||
| 241 | split it into several short lines. See also | ||
| 242 | `guix-info-multiline-prefix'. | ||
| 243 | |||
| 244 | If FACE is non-nil, propertize inserted line(s) with this FACE." | ||
| 245 | (guix-split-insert val face | ||
| 246 | guix-info-fill-column | ||
| 247 | (concat "\n" guix-info-multiline-prefix))) | ||
| 248 | |||
| 249 | (defun guix-info-insert-val-simple (val &optional face-or-fun) | ||
| 250 | "Format and insert parameter value VAL at point. | ||
| 251 | |||
| 252 | This function is intended to be called after | ||
| 253 | `guix-info-insert-title-simple'. | ||
| 254 | |||
| 255 | If VAL is a one-line string longer than `guix-info-fill-column', | ||
| 256 | split it into several short lines and indent each line with | ||
| 257 | `guix-info-indent' spaces. | ||
| 258 | |||
| 259 | If FACE-OR-FUN is a face, propertize inserted line(s) with this FACE. | ||
| 260 | |||
| 261 | If FACE-OR-FUN is a function, call it with VAL as argument. If | ||
| 262 | VAL is a list, call the function on each element of this list." | ||
| 263 | (if (null val) | ||
| 264 | (progn (guix-info-insert-indent) | ||
| 265 | (guix-format-insert nil)) | ||
| 266 | (let ((prefix (concat "\n" (guix-info-get-indent)))) | ||
| 267 | (insert prefix) | ||
| 268 | (if (functionp face-or-fun) | ||
| 269 | (guix-mapinsert face-or-fun | ||
| 270 | (if (listp val) val (list val)) | ||
| 271 | prefix) | ||
| 272 | (guix-split-insert val face-or-fun | ||
| 273 | guix-info-fill-column prefix))))) | ||
| 274 | |||
| 275 | (defun guix-info-insert-action-button (label action &optional message | ||
| 276 | &rest properties) | ||
| 277 | "Make action button with LABEL and insert it at point. | ||
| 278 | For the meaning of ACTION, MESSAGE and PROPERTIES, see | ||
| 279 | `guix-insert-button'." | ||
| 280 | (apply #'guix-insert-button | ||
| 281 | label 'guix-info-action-button action message | ||
| 282 | 'mouse-face 'guix-info-action-button-mouse | ||
| 283 | properties)) | ||
| 284 | |||
| 285 | (defun guix-info-insert-file-path (path &optional _) | ||
| 286 | "Make button from file PATH and insert it at point." | ||
| 287 | (guix-insert-button | ||
| 288 | path 'guix-info-file-path | ||
| 289 | (lambda (btn) (find-file (button-label btn))) | ||
| 290 | "Find file")) | ||
| 291 | |||
| 292 | (defun guix-info-insert-url (url &optional _) | ||
| 293 | "Make button from URL and insert it at point." | ||
| 294 | (guix-insert-button | ||
| 295 | url 'guix-info-url | ||
| 296 | (lambda (btn) (browse-url (button-label btn))) | ||
| 297 | "Browse URL")) | ||
| 298 | |||
| 299 | (defun guix-info-insert-time (seconds &optional _) | ||
| 300 | "Insert formatted time string using SECONDS at point." | ||
| 301 | (guix-info-insert-val-default (guix-get-time-string seconds) | ||
| 302 | 'guix-info-time)) | ||
| 303 | |||
| 304 | |||
| 305 | (defvar guix-info-mode-map | ||
| 306 | (let ((map (make-sparse-keymap))) | ||
| 307 | (set-keymap-parent | ||
| 308 | map (make-composed-keymap button-buffer-map | ||
| 309 | special-mode-map)) | ||
| 310 | map) | ||
| 311 | "Parent keymap for info buffers.") | ||
| 312 | |||
| 313 | (define-derived-mode guix-info-mode special-mode "Guix-Info" | ||
| 314 | "Parent mode for displaying information in info buffers.") | ||
| 315 | |||
| 316 | |||
| 317 | ;;; Displaying packages | ||
| 318 | |||
| 319 | (guix-define-buffer-type info package | ||
| 320 | :required (id installed non-unique)) | ||
| 321 | |||
| 322 | (defface guix-package-info-name | ||
| 323 | '((t :inherit font-lock-keyword-face)) | ||
| 324 | "Face used for a name of a package." | ||
| 325 | :group 'guix-package-info) | ||
| 326 | |||
| 327 | (defface guix-package-info-version | ||
| 328 | '((t :inherit font-lock-builtin-face)) | ||
| 329 | "Face used for a version of a package." | ||
| 330 | :group 'guix-package-info) | ||
| 331 | |||
| 332 | (defface guix-package-info-synopsis | ||
| 333 | '((t :inherit font-lock-doc-face)) | ||
| 334 | "Face used for a synopsis of a package." | ||
| 335 | :group 'guix-package-info) | ||
| 336 | |||
| 337 | (defface guix-package-info-description | ||
| 338 | '((t)) | ||
| 339 | "Face used for a description of a package." | ||
| 340 | :group 'guix-package-info) | ||
| 341 | |||
| 342 | (defface guix-package-info-license | ||
| 343 | '((t :inherit font-lock-string-face)) | ||
| 344 | "Face used for a license of a package." | ||
| 345 | :group 'guix-package-info) | ||
| 346 | |||
| 347 | (defface guix-package-info-location | ||
| 348 | '((t :inherit link)) | ||
| 349 | "Face used for a location of a package." | ||
| 350 | :group 'guix-package-info) | ||
| 351 | |||
| 352 | (defface guix-package-info-installed-outputs | ||
| 353 | '((default :weight bold) | ||
| 354 | (((class color) (min-colors 88) (background light)) | ||
| 355 | :foreground "ForestGreen") | ||
| 356 | (((class color) (min-colors 88) (background dark)) | ||
| 357 | :foreground "PaleGreen") | ||
| 358 | (((class color) (min-colors 8)) | ||
| 359 | :foreground "green") | ||
| 360 | (t :underline t)) | ||
| 361 | "Face used for installed outputs of a package." | ||
| 362 | :group 'guix-package-info) | ||
| 363 | |||
| 364 | (defface guix-package-info-uninstalled-outputs | ||
| 365 | '((t :weight bold)) | ||
| 366 | "Face used for uninstalled outputs of a package." | ||
| 367 | :group 'guix-package-info) | ||
| 368 | |||
| 369 | (defface guix-package-info-obsolete | ||
| 370 | '((t :inherit error)) | ||
| 371 | "Face used if a package is obsolete." | ||
| 372 | :group 'guix-package-info) | ||
| 373 | |||
| 374 | (defun guix-package-info-insert-description (desc &optional _) | ||
| 375 | "Insert description DESC at point." | ||
| 376 | (guix-info-insert-val-simple desc 'guix-package-info-description)) | ||
| 377 | |||
| 378 | (defun guix-package-info-insert-location (location &optional _) | ||
| 379 | "Make button from file LOCATION and insert it at point." | ||
| 380 | (guix-insert-button | ||
| 381 | location 'guix-package-info-location | ||
| 382 | (lambda (btn) (guix-find-location (button-label btn))) | ||
| 383 | "Find location of this package")) | ||
| 384 | |||
| 385 | (defmacro guix-package-info-define-insert-inputs (&optional type) | ||
| 386 | "Define a face and a function for inserting package inputs. | ||
| 387 | TYPE is a type of inputs. | ||
| 388 | Function name is `guix-package-info-insert-TYPE-inputs'. | ||
| 389 | Face name is `guix-package-info-TYPE-inputs'." | ||
| 390 | (let* ((type-str (symbol-name type)) | ||
| 391 | (type-name (and type (concat type-str "-"))) | ||
| 392 | (type-desc (and type (concat type-str " "))) | ||
| 393 | (face (intern (concat "guix-package-info-" type-name "inputs"))) | ||
| 394 | (fun (intern (concat "guix-package-info-insert-" type-name "inputs")))) | ||
| 395 | `(progn | ||
| 396 | (defface ,face | ||
| 397 | '((t :inherit button)) | ||
| 398 | ,(concat "Face used for " type-desc "inputs of a package.") | ||
| 399 | :group 'guix-package-info) | ||
| 400 | |||
| 401 | (defun ,fun (inputs &optional _) | ||
| 402 | ,(concat "Make buttons from " type-desc "INPUTS and insert them at point.") | ||
| 403 | (guix-package-info-insert-full-names inputs ',face))))) | ||
| 404 | |||
| 405 | (guix-package-info-define-insert-inputs) | ||
| 406 | (guix-package-info-define-insert-inputs native) | ||
| 407 | (guix-package-info-define-insert-inputs propagated) | ||
| 408 | |||
| 409 | (defun guix-package-info-insert-full-names (names face) | ||
| 410 | "Make buttons from package NAMES and insert them at point. | ||
| 411 | NAMES is a list of strings. | ||
| 412 | Propertize buttons with FACE." | ||
| 413 | (if names | ||
| 414 | (guix-info-insert-val-default | ||
| 415 | (with-temp-buffer | ||
| 416 | (guix-mapinsert (lambda (name) | ||
| 417 | (guix-package-info-insert-full-name | ||
| 418 | name face)) | ||
| 419 | names | ||
| 420 | guix-list-separator) | ||
| 421 | (buffer-substring (point-min) (point-max)))) | ||
| 422 | (guix-format-insert nil))) | ||
| 423 | |||
| 424 | (defun guix-package-info-insert-full-name (name face) | ||
| 425 | "Make button and insert package NAME at point. | ||
| 426 | Propertize package button with FACE." | ||
| 427 | (guix-insert-button | ||
| 428 | name face | ||
| 429 | (lambda (btn) | ||
| 430 | (guix-package-info-get-show 'name (button-label btn))) | ||
| 431 | "Describe this package")) | ||
| 432 | |||
| 433 | |||
| 434 | ;;; Inserting outputs and installed parameters | ||
| 435 | |||
| 436 | (defvar guix-package-info-output-format "%-10s" | ||
| 437 | "String used to format output names of the packages. | ||
| 438 | It should be a '%s'-sequence. After inserting an output name | ||
| 439 | formatted with this string, an action button is inserted.") | ||
| 440 | |||
| 441 | (defvar guix-package-info-obsolete-string "(This package is obsolete)" | ||
| 442 | "String used if a package is obsolete.") | ||
| 443 | |||
| 444 | (defun guix-package-info-insert-outputs (outputs entry) | ||
| 445 | "Insert OUTPUTS from package ENTRY at point." | ||
| 446 | (and (guix-get-key-val entry 'obsolete) | ||
| 447 | (guix-package-info-insert-obsolete-text)) | ||
| 448 | (and (guix-get-key-val entry 'non-unique) | ||
| 449 | (guix-get-key-val entry 'installed) | ||
| 450 | (guix-package-info-insert-non-unique-text | ||
| 451 | (guix-get-full-name entry))) | ||
| 452 | (insert "\n") | ||
| 453 | (mapc (lambda (output) | ||
| 454 | (guix-package-info-insert-output output entry)) | ||
| 455 | outputs)) | ||
| 456 | |||
| 457 | (defun guix-package-info-insert-obsolete-text () | ||
| 458 | "Insert a message about obsolete package at point." | ||
| 459 | (guix-info-insert-indent) | ||
| 460 | (guix-format-insert guix-package-info-obsolete-string | ||
| 461 | 'guix-package-info-obsolete)) | ||
| 462 | |||
| 463 | (defun guix-package-info-insert-non-unique-text (full-name) | ||
| 464 | "Insert a message about non-unique package with FULL-NAME at point." | ||
| 465 | (insert "\n") | ||
| 466 | (guix-info-insert-indent) | ||
| 467 | (insert "Installed outputs are displayed for a non-unique ") | ||
| 468 | (guix-package-info-insert-full-name full-name | ||
| 469 | 'guix-package-info-inputs) | ||
| 470 | (insert " package.")) | ||
| 471 | |||
| 472 | (defun guix-package-info-insert-output (output entry) | ||
| 473 | "Insert OUTPUT at point. | ||
| 474 | Make some fancy text with buttons and additional stuff if the | ||
| 475 | current OUTPUT is installed (if there is such output in | ||
| 476 | `installed' parameter of a package ENTRY)." | ||
| 477 | (let* ((installed (guix-get-key-val entry 'installed)) | ||
| 478 | (obsolete (guix-get-key-val entry 'obsolete)) | ||
| 479 | (installed-entry (cl-find-if | ||
| 480 | (lambda (entry) | ||
| 481 | (string= (guix-get-key-val entry 'output) | ||
| 482 | output)) | ||
| 483 | installed)) | ||
| 484 | (action-type (if installed-entry 'delete 'install))) | ||
| 485 | (guix-info-insert-indent) | ||
| 486 | (guix-format-insert output | ||
| 487 | (if installed-entry | ||
| 488 | 'guix-package-info-installed-outputs | ||
| 489 | 'guix-package-info-uninstalled-outputs) | ||
| 490 | guix-package-info-output-format) | ||
| 491 | (guix-package-info-insert-action-button action-type entry output) | ||
| 492 | (when obsolete | ||
| 493 | (guix-info-insert-indent) | ||
| 494 | (guix-package-info-insert-action-button 'upgrade entry output)) | ||
| 495 | (insert "\n") | ||
| 496 | (when installed-entry | ||
| 497 | (guix-info-insert-entry installed-entry 'installed 2)))) | ||
| 498 | |||
| 499 | (defun guix-package-info-insert-action-button (type entry output) | ||
| 500 | "Insert button to process an action on a package OUTPUT at point. | ||
| 501 | TYPE is one of the following symbols: `install', `delete', `upgrade'. | ||
| 502 | ENTRY is an alist with package info." | ||
| 503 | (let ((type-str (capitalize (symbol-name type))) | ||
| 504 | (full-name (guix-get-full-name entry output))) | ||
| 505 | (guix-info-insert-action-button | ||
| 506 | type-str | ||
| 507 | (lambda (btn) | ||
| 508 | (guix-process-package-actions | ||
| 509 | (list (button-get btn 'action-type) | ||
| 510 | (list (button-get btn 'id) | ||
| 511 | (button-get btn 'output))))) | ||
| 512 | (concat type-str " '" full-name "'") | ||
| 513 | 'action-type type | ||
| 514 | 'id (guix-get-key-val entry 'id) | ||
| 515 | 'output output))) | ||
| 516 | |||
| 517 | (defun guix-package-info-insert-output-path (path &optional _) | ||
| 518 | "Insert PATH of the installed output." | ||
| 519 | (guix-info-insert-val-simple path #'guix-info-insert-file-path)) | ||
| 520 | |||
| 521 | (defun guix-package-info-insert-output-dependencies (deps &optional _) | ||
| 522 | "Insert dependencies DEPS of the installed output." | ||
| 523 | (guix-info-insert-val-simple deps #'guix-info-insert-file-path)) | ||
| 524 | |||
| 525 | |||
| 526 | ;;; Displaying generations | ||
| 527 | |||
| 528 | (guix-define-buffer-type info generation) | ||
| 529 | |||
| 530 | (defface guix-generation-info-number | ||
| 531 | '((t :inherit font-lock-keyword-face)) | ||
| 532 | "Face used for a number of a generation." | ||
| 533 | :group 'guix-generation-info) | ||
| 534 | |||
| 535 | (declare-function guix-package-list-get-show "guix-list" t t) | ||
| 536 | |||
| 537 | (defun guix-generation-info-insert-number (number &optional _) | ||
| 538 | "Insert generation NUMBER and action buttons." | ||
| 539 | (guix-info-insert-val-default number 'guix-generation-info-number) | ||
| 540 | (guix-info-insert-indent) | ||
| 541 | (guix-info-insert-action-button | ||
| 542 | "Packages" | ||
| 543 | (lambda (btn) | ||
| 544 | (guix-package-list-get-show 'generation | ||
| 545 | (button-get btn 'number))) | ||
| 546 | "Show installed packages for this generation" | ||
| 547 | 'number number) | ||
| 548 | (guix-info-insert-indent) | ||
| 549 | (guix-info-insert-action-button | ||
| 550 | "Delete" | ||
| 551 | (lambda (btn) (error "Sorry, not implemented yet")) | ||
| 552 | "Delete this generation")) | ||
| 553 | |||
| 554 | (provide 'guix-info) | ||
| 555 | |||
| 556 | ;;; guix-info.el ends here | ||
diff --git a/emacs/guix-init.el.in b/emacs/guix-init.el.in new file mode 100644 index 00000000000..4e627281875 --- /dev/null +++ b/emacs/guix-init.el.in | |||
| @@ -0,0 +1,14 @@ | |||
| 1 | (require 'guix-autoloads) | ||
| 2 | |||
| 3 | (defvar guix-load-path | ||
| 4 | (replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@") | ||
| 5 | "Directory with scheme files for \"guix.el\" package.") | ||
| 6 | |||
| 7 | (defvar guix-default-profile | ||
| 8 | (concat (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix") | ||
| 9 | "/profiles/per-user/" | ||
| 10 | (getenv "USER") | ||
| 11 | "/guix-profile") | ||
| 12 | "Default Guix profile.") | ||
| 13 | |||
| 14 | (provide 'guix-init) | ||
diff --git a/emacs/guix-list.el b/emacs/guix-list.el new file mode 100644 index 00000000000..0460d20f1bc --- /dev/null +++ b/emacs/guix-list.el | |||
| @@ -0,0 +1,586 @@ | |||
| 1 | ;;; guix-list.el --- List buffers for displaying entries -*- lexical-binding: t -*- | ||
| 2 | |||
| 3 | ;; Copyright © 2014 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 a list-like buffer for displaying information | ||
| 23 | ;; about Guix packages and generations. | ||
| 24 | |||
| 25 | ;;; Code: | ||
| 26 | |||
| 27 | (require 'cl-lib) | ||
| 28 | (require 'tabulated-list) | ||
| 29 | (require 'guix-info) | ||
| 30 | (require 'guix-history) | ||
| 31 | (require 'guix-base) | ||
| 32 | (require 'guix-utils) | ||
| 33 | |||
| 34 | (defgroup guix-list nil | ||
| 35 | "General settings for list buffers." | ||
| 36 | :prefix "guix-list-" | ||
| 37 | :group 'guix) | ||
| 38 | |||
| 39 | (defface guix-list-file-path | ||
| 40 | '((t :inherit guix-info-file-path)) | ||
| 41 | "Face used for file paths." | ||
| 42 | :group 'guix-list) | ||
| 43 | |||
| 44 | (defcustom guix-list-describe-warning-count 10 | ||
| 45 | "The maximum number of entries for describing without a warning. | ||
| 46 | If a user wants to describe more than this number of marked | ||
| 47 | entries, he will be prompted for confirmation." | ||
| 48 | :type 'integer | ||
| 49 | :group 'guix-list) | ||
| 50 | |||
| 51 | (defvar guix-list-column-format | ||
| 52 | `((package | ||
| 53 | (name 20 t) | ||
| 54 | (version 10 nil) | ||
| 55 | (outputs 13 t) | ||
| 56 | (installed 13 t) | ||
| 57 | (synopsis 30 nil)) | ||
| 58 | (generation | ||
| 59 | (number 5 | ||
| 60 | ,(lambda (a b) (guix-list-sort-numerically 0 a b)) | ||
| 61 | :right-align t) | ||
| 62 | (time 20 t) | ||
| 63 | (path 30 t))) | ||
| 64 | "Columns displayed in list buffers. | ||
| 65 | Each element of the list has a form: | ||
| 66 | |||
| 67 | (ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...)) | ||
| 68 | |||
| 69 | PARAM is the name of an entry parameter of ENTRY-TYPE. For the | ||
| 70 | meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.") | ||
| 71 | |||
| 72 | (defvar guix-list-column-titles | ||
| 73 | '((generation | ||
| 74 | (number . "N."))) | ||
| 75 | "Column titles for list buffers. | ||
| 76 | Has the same structure as `guix-param-titles', but titles from | ||
| 77 | this list have a priority.") | ||
| 78 | |||
| 79 | (defvar guix-list-column-value-methods | ||
| 80 | '((package | ||
| 81 | (name . guix-package-list-get-name) | ||
| 82 | (synopsis . guix-list-get-one-line) | ||
| 83 | (description . guix-list-get-one-line) | ||
| 84 | (installed . guix-package-list-get-installed-outputs)) | ||
| 85 | (generation | ||
| 86 | (time . guix-list-get-time) | ||
| 87 | (path . guix-list-get-file-path))) | ||
| 88 | "Methods for inserting parameter values in columns. | ||
| 89 | Each element of the list has a form: | ||
| 90 | |||
| 91 | (ENTRY-TYPE . ((PARAM . FUN) ...)) | ||
| 92 | |||
| 93 | PARAM is the name of an entry parameter of ENTRY-TYPE. | ||
| 94 | |||
| 95 | FUN is a function returning a value that will be inserted. The | ||
| 96 | function is called with 2 arguments: the first one is the value | ||
| 97 | of the parameter; the second argument is an entry info (alist of | ||
| 98 | parameters and their values).") | ||
| 99 | |||
| 100 | (defun guix-list-get-param-title (entry-type param) | ||
| 101 | "Return title of an ENTRY-TYPE entry parameter PARAM." | ||
| 102 | (or (guix-get-key-val guix-list-column-titles | ||
| 103 | entry-type param) | ||
| 104 | (guix-get-param-title entry-type param))) | ||
| 105 | |||
| 106 | (defun guix-list-get-column-format (entry-type) | ||
| 107 | "Return column format for ENTRY-TYPE." | ||
| 108 | (guix-get-key-val guix-list-column-format entry-type)) | ||
| 109 | |||
| 110 | (defun guix-list-get-displayed-params (entry-type) | ||
| 111 | "Return list of parameters of ENTRY-TYPE that should be displayed." | ||
| 112 | (mapcar #'car | ||
| 113 | (guix-list-get-column-format entry-type))) | ||
| 114 | |||
| 115 | (defun guix-list-get-sort-key (entry-type param &optional invert) | ||
| 116 | "Return suitable sort key for `tabulated-list-sort-key'. | ||
| 117 | Define column title by ENTRY-TYPE and PARAM. If INVERT is | ||
| 118 | non-nil, invert the sort." | ||
| 119 | (when (memq param (guix-list-get-displayed-params entry-type)) | ||
| 120 | (cons (guix-list-get-param-title entry-type param) invert))) | ||
| 121 | |||
| 122 | (defun guix-list-sort-numerically (column a b) | ||
| 123 | "Compare COLUMN of tabulated entries A and B numerically. | ||
| 124 | It is a sort predicate for `tabulated-list-format'. | ||
| 125 | Return non-nil, if B is bigger than A." | ||
| 126 | (cl-flet ((num (entry) | ||
| 127 | (string-to-number (aref (cadr entry) column)))) | ||
| 128 | (> (num b) (num a)))) | ||
| 129 | |||
| 130 | (defun guix-list-make-tabulated-vector (entry-type fun) | ||
| 131 | "Call FUN on each column specification for ENTRY-TYPE. | ||
| 132 | |||
| 133 | FUN is called with 2 argument: parameter name and column | ||
| 134 | specification (see `guix-list-column-format'). | ||
| 135 | |||
| 136 | Return a vector made of values of FUN calls." | ||
| 137 | (apply #'vector | ||
| 138 | (mapcar (lambda (col-spec) | ||
| 139 | (funcall fun (car col-spec) (cdr col-spec))) | ||
| 140 | (guix-list-get-column-format entry-type)))) | ||
| 141 | |||
| 142 | (defun guix-list-get-list-format (entry-type) | ||
| 143 | "Return ENTRY-TYPE list specification for `tabulated-list-format'." | ||
| 144 | (guix-list-make-tabulated-vector | ||
| 145 | entry-type | ||
| 146 | (lambda (param spec) | ||
| 147 | (cons (guix-list-get-param-title entry-type param) | ||
| 148 | spec)))) | ||
| 149 | |||
| 150 | (defun guix-list-insert-entries (entries entry-type) | ||
| 151 | "Display ENTRIES of ENTRY-TYPE in the current list buffer. | ||
| 152 | ENTRIES should have a form of `guix-entries'." | ||
| 153 | (setq tabulated-list-entries | ||
| 154 | (guix-list-get-tabulated-entries entries entry-type)) | ||
| 155 | (tabulated-list-print)) | ||
| 156 | |||
| 157 | (defun guix-list-get-tabulated-entries (entries entry-type) | ||
| 158 | "Return list of values of ENTRY-TYPE for `tabulated-list-entries'. | ||
| 159 | Values are taken from ENTRIES which should have the form of | ||
| 160 | `guix-entries'." | ||
| 161 | (mapcar (lambda (entry) | ||
| 162 | (list (guix-get-key-val entry 'id) | ||
| 163 | (guix-list-get-tabulated-entry entry entry-type))) | ||
| 164 | entries)) | ||
| 165 | |||
| 166 | (defun guix-list-get-tabulated-entry (entry entry-type) | ||
| 167 | "Return array of values for `tabulated-list-entries'. | ||
| 168 | Parameters are taken from ENTRY of ENTRY-TYPE." | ||
| 169 | (guix-list-make-tabulated-vector | ||
| 170 | entry-type | ||
| 171 | (lambda (param _) | ||
| 172 | (let ((val (guix-get-key-val entry param)) | ||
| 173 | (fun (guix-get-key-val guix-list-column-value-methods | ||
| 174 | entry-type param))) | ||
| 175 | (if (and val fun) | ||
| 176 | (funcall fun val entry) | ||
| 177 | (guix-get-string val)))))) | ||
| 178 | |||
| 179 | (defun guix-list-get-one-line (str &optional _) | ||
| 180 | "Return one-line string from a multi-line STR." | ||
| 181 | (guix-get-one-line str)) | ||
| 182 | |||
| 183 | (defun guix-list-get-time (seconds &optional _) | ||
| 184 | "Return formatted time string from SECONDS." | ||
| 185 | (guix-get-time-string seconds)) | ||
| 186 | |||
| 187 | (defun guix-list-get-file-path (path &optional _) | ||
| 188 | "Return PATH button specification for `tabulated-list-entries'." | ||
| 189 | (list path | ||
| 190 | 'face 'guix-list-file-path | ||
| 191 | 'action (lambda (btn) (find-file (button-label btn))) | ||
| 192 | 'follow-link t | ||
| 193 | 'help-echo "Find file")) | ||
| 194 | |||
| 195 | (defun guix-list-current-id () | ||
| 196 | "Return ID of the current entry." | ||
| 197 | (or (tabulated-list-get-id) | ||
| 198 | (user-error "No entry here"))) | ||
| 199 | |||
| 200 | (defun guix-list-current-entry () | ||
| 201 | "Return alist of the current entry info." | ||
| 202 | (guix-get-entry-by-id (guix-list-current-id) guix-entries)) | ||
| 203 | |||
| 204 | (defun guix-list-for-each-line (fun &rest args) | ||
| 205 | "Call FUN with ARGS for each entry line." | ||
| 206 | (or (derived-mode-p 'guix-list-mode) | ||
| 207 | (error "The current buffer is not in Guix List mode")) | ||
| 208 | (save-excursion | ||
| 209 | (goto-char (point-min)) | ||
| 210 | (while (not (eobp)) | ||
| 211 | (apply fun args) | ||
| 212 | (forward-line)))) | ||
| 213 | |||
| 214 | (defun guix-list-fold-lines (fun init) | ||
| 215 | "Fold over entry lines in the current list buffer. | ||
| 216 | Call FUN with RESULT as argument for each line, using INIT as | ||
| 217 | the initial value of RESULT. Return the final result." | ||
| 218 | (let ((res init)) | ||
| 219 | (guix-list-for-each-line | ||
| 220 | (lambda () (setq res (funcall fun res)))) | ||
| 221 | res)) | ||
| 222 | |||
| 223 | |||
| 224 | ;;; Marking and sorting | ||
| 225 | |||
| 226 | (defvar-local guix-list-marked nil | ||
| 227 | "List of the marked entries. | ||
| 228 | Each element of the list has a form: | ||
| 229 | |||
| 230 | (ID MARK-NAME . ARGS) | ||
| 231 | |||
| 232 | ID is an entry ID. | ||
| 233 | MARK-NAME is a symbol from `guix-list-mark-alist'. | ||
| 234 | ARGS is a list of additional values.") | ||
| 235 | |||
| 236 | (defvar guix-list-mark-alist | ||
| 237 | '((empty . ?\s) | ||
| 238 | (general . ?*)) | ||
| 239 | "Alist of available mark names and mark characters.") | ||
| 240 | |||
| 241 | (defsubst guix-list-get-mark (name) | ||
| 242 | "Return mark character by its NAME." | ||
| 243 | (or (guix-get-key-val guix-list-mark-alist name) | ||
| 244 | (error "Mark '%S' not found" name))) | ||
| 245 | |||
| 246 | (defsubst guix-list-get-mark-string (name) | ||
| 247 | "Return mark string by its NAME." | ||
| 248 | (string (guix-list-get-mark name))) | ||
| 249 | |||
| 250 | (defun guix-list-current-mark () | ||
| 251 | "Return mark character of the current line." | ||
| 252 | (char-after (line-beginning-position))) | ||
| 253 | |||
| 254 | (defun guix-list-get-marked (&rest mark-names) | ||
| 255 | "Return list of specs of entries marked with any mark from MARK-NAMES. | ||
| 256 | Entry specs are elements from `guix-list-marked' list. | ||
| 257 | If MARK-NAMES are not specified, use all marks from | ||
| 258 | `guix-list-mark-alist' except the `empty' one." | ||
| 259 | (or mark-names | ||
| 260 | (setq mark-names | ||
| 261 | (delq 'empty | ||
| 262 | (mapcar #'car guix-list-mark-alist)))) | ||
| 263 | (cl-remove-if-not (lambda (assoc) | ||
| 264 | (memq (cadr assoc) mark-names)) | ||
| 265 | guix-list-marked)) | ||
| 266 | |||
| 267 | (defun guix-list-get-marked-args (mark-name) | ||
| 268 | "Return list of (ID . ARGS) elements from lines marked with MARK-NAME. | ||
| 269 | See `guix-list-marked' for the meaning of ARGS." | ||
| 270 | (mapcar (lambda (spec) | ||
| 271 | (let ((id (car spec)) | ||
| 272 | (args (cddr spec))) | ||
| 273 | (cons id args))) | ||
| 274 | (guix-list-get-marked mark-name))) | ||
| 275 | |||
| 276 | (defun guix-list-get-marked-id-list (&rest mark-names) | ||
| 277 | "Return list of IDs of entries marked with any mark from MARK-NAMES. | ||
| 278 | See `guix-list-get-marked' for details." | ||
| 279 | (mapcar #'car (apply #'guix-list-get-marked mark-names))) | ||
| 280 | |||
| 281 | (defun guix-list-mark (mark-name &optional advance &rest args) | ||
| 282 | "Put a mark on the current line. | ||
| 283 | Also add the current entry to `guix-list-marked' using its ID and ARGS. | ||
| 284 | MARK-NAME is a symbol from `guix-list-mark-alist'. | ||
| 285 | If ADVANCE is non-nil, move forward by one line after marking. | ||
| 286 | Interactively, put a general mark and move to the next line." | ||
| 287 | (interactive '(general t)) | ||
| 288 | (let ((id (guix-list-current-id))) | ||
| 289 | (if (eq mark-name 'empty) | ||
| 290 | (setq guix-list-marked (assq-delete-all id guix-list-marked)) | ||
| 291 | (let ((assoc (assq id guix-list-marked)) | ||
| 292 | (val (cons mark-name args))) | ||
| 293 | (if assoc | ||
| 294 | (setcdr assoc val) | ||
| 295 | (push (cons id val) guix-list-marked))))) | ||
| 296 | (tabulated-list-put-tag (guix-list-get-mark-string mark-name) | ||
| 297 | advance)) | ||
| 298 | |||
| 299 | (defun guix-list-mark-all (mark-name) | ||
| 300 | "Mark all lines with MARK-NAME mark. | ||
| 301 | MARK-NAME is a symbol from `guix-list-mark-alist'. | ||
| 302 | Interactively, put a general mark on all lines." | ||
| 303 | (interactive '(general)) | ||
| 304 | (guix-list-for-each-line #'guix-list-mark mark-name)) | ||
| 305 | |||
| 306 | (defun guix-list-unmark () | ||
| 307 | "Unmark the current line and move to the next line." | ||
| 308 | (interactive) | ||
| 309 | (guix-list-mark 'empty t)) | ||
| 310 | |||
| 311 | (defun guix-list-unmark-backward () | ||
| 312 | "Move up one line and unmark it." | ||
| 313 | (interactive) | ||
| 314 | (forward-line -1) | ||
| 315 | (guix-list-mark 'empty)) | ||
| 316 | |||
| 317 | (defun guix-list-unmark-all () | ||
| 318 | "Unmark all lines." | ||
| 319 | (interactive) | ||
| 320 | (guix-list-mark-all 'empty)) | ||
| 321 | |||
| 322 | (defun guix-list-restore-marks () | ||
| 323 | "Put marks according to `guix-list-mark-alist'." | ||
| 324 | (guix-list-for-each-line | ||
| 325 | (lambda () | ||
| 326 | (let ((mark-name (car (guix-get-key-val guix-list-marked | ||
| 327 | (guix-list-current-id))))) | ||
| 328 | (tabulated-list-put-tag | ||
| 329 | (guix-list-get-mark-string (or mark-name 'empty))))))) | ||
| 330 | |||
| 331 | (defun guix-list-sort (&optional n) | ||
| 332 | "Sort guix list entries by the column at point. | ||
| 333 | With a numeric prefix argument N, sort the Nth column. | ||
| 334 | Same as `tabulated-list-sort', but also restore marks after sorting." | ||
| 335 | (interactive "P") | ||
| 336 | (tabulated-list-sort n) | ||
| 337 | (guix-list-restore-marks)) | ||
| 338 | |||
| 339 | |||
| 340 | (defvar guix-list-mode-map | ||
| 341 | (let ((map (make-sparse-keymap))) | ||
| 342 | (set-keymap-parent map tabulated-list-mode-map) | ||
| 343 | (define-key map (kbd "m") 'guix-list-mark) | ||
| 344 | (define-key map (kbd "*") 'guix-list-mark) | ||
| 345 | (define-key map (kbd "M") 'guix-list-mark-all) | ||
| 346 | (define-key map (kbd "u") 'guix-list-unmark) | ||
| 347 | (define-key map (kbd "U") 'guix-list-unmark-all) | ||
| 348 | (define-key map (kbd "DEL") 'guix-list-unmark-backward) | ||
| 349 | (define-key map [remap tabulated-list-sort] 'guix-list-sort) | ||
| 350 | map) | ||
| 351 | "Parent keymap for list buffers.") | ||
| 352 | |||
| 353 | (define-derived-mode guix-list-mode tabulated-list-mode "Guix-List" | ||
| 354 | "Parent mode for displaying information in list buffers." | ||
| 355 | (setq tabulated-list-padding 2)) | ||
| 356 | |||
| 357 | (defmacro guix-list-define-entry-type (entry-type &rest args) | ||
| 358 | "Define common stuff for displaying ENTRY-TYPE entries in list buffers. | ||
| 359 | |||
| 360 | Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The | ||
| 361 | following keywords are available: | ||
| 362 | |||
| 363 | - `:sort-key' - default sort key for the tabulated list buffer. | ||
| 364 | |||
| 365 | - `:invert-sort' - if non-nil, invert initial sort. | ||
| 366 | |||
| 367 | - `:marks' - default value for the defined | ||
| 368 | `guix-ENTRY-TYPE-mark-alist' variable. | ||
| 369 | |||
| 370 | This macro defines the following functions: | ||
| 371 | |||
| 372 | - `guix-ENTRY-TYPE-describe' - display marked entries in info buffer. | ||
| 373 | |||
| 374 | - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark | ||
| 375 | specified in `:marks' argument." | ||
| 376 | (let* ((entry-type-str (symbol-name entry-type)) | ||
| 377 | (entry-str (concat entry-type-str " entries")) | ||
| 378 | (prefix (concat "guix-" entry-type-str "-list")) | ||
| 379 | (mode-str (concat prefix "-mode")) | ||
| 380 | (init-fun (intern (concat prefix "-mode-initialize"))) | ||
| 381 | (describe-fun (intern (concat prefix "-describe"))) | ||
| 382 | (marks-var (intern (concat prefix "-mark-alist"))) | ||
| 383 | (marks-val nil) | ||
| 384 | (sort-key nil) | ||
| 385 | (invert-sort nil)) | ||
| 386 | |||
| 387 | ;; Process the keyword args. | ||
| 388 | (while (keywordp (car args)) | ||
| 389 | (pcase (pop args) | ||
| 390 | (`:sort-key (setq sort-key (pop args))) | ||
| 391 | (`:invert-sort (setq invert-sort (pop args))) | ||
| 392 | (`:marks (setq marks-val (pop args))) | ||
| 393 | (_ (pop args)))) | ||
| 394 | |||
| 395 | `(progn | ||
| 396 | (defvar ,marks-var ',marks-val | ||
| 397 | ,(concat "Alist of additional marks for `" mode-str "'.\n" | ||
| 398 | "Marks from this list are added to `guix-list-mark-alist'.")) | ||
| 399 | |||
| 400 | ,@(mapcar (lambda (mark-spec) | ||
| 401 | (let* ((mark-name (car mark-spec)) | ||
| 402 | (mark-name-str (symbol-name mark-name))) | ||
| 403 | `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) () | ||
| 404 | ,(concat "Put '" mark-name-str "' mark and move to the next line.\n" | ||
| 405 | "Also add the current entry to `guix-list-marked'.") | ||
| 406 | (interactive) | ||
| 407 | (guix-list-mark ',mark-name t)))) | ||
| 408 | marks-val) | ||
| 409 | |||
| 410 | (defun ,describe-fun (&optional arg) | ||
| 411 | ,(concat "Describe " entry-str " marked with a general mark.\n" | ||
| 412 | "If no entry is marked, describe the current " entry-type-str ".\n" | ||
| 413 | "With prefix (if ARG is non-nil), describe the " entry-str "\n" | ||
| 414 | "marked with any mark.") | ||
| 415 | (interactive "P") | ||
| 416 | (let* ((ids (or (apply #'guix-list-get-marked-id-list | ||
| 417 | (unless arg '(general))) | ||
| 418 | (list (guix-list-current-id)))) | ||
| 419 | (count (length ids))) | ||
| 420 | (when (or (<= count guix-list-describe-warning-count) | ||
| 421 | (y-or-n-p (format "Do you really want to describe %d entries? " | ||
| 422 | count))) | ||
| 423 | (,(intern (concat "guix-" entry-type-str "-info-get-show")) | ||
| 424 | 'id ids)))) | ||
| 425 | |||
| 426 | (defun ,init-fun () | ||
| 427 | ,(concat "Initial settings for `" mode-str "'.") | ||
| 428 | ,(when sort-key | ||
| 429 | `(setq tabulated-list-sort-key | ||
| 430 | (guix-list-get-sort-key | ||
| 431 | ',entry-type ',sort-key ,invert-sort))) | ||
| 432 | (setq tabulated-list-format | ||
| 433 | (guix-list-get-list-format ',entry-type)) | ||
| 434 | (setq-local guix-list-mark-alist | ||
| 435 | (append guix-list-mark-alist ,marks-var)) | ||
| 436 | (tabulated-list-init-header))))) | ||
| 437 | |||
| 438 | (put 'guix-list-define-entry-type 'lisp-indent-function 'defun) | ||
| 439 | |||
| 440 | |||
| 441 | ;;; Displaying packages | ||
| 442 | |||
| 443 | (guix-define-buffer-type list package) | ||
| 444 | |||
| 445 | (guix-list-define-entry-type package | ||
| 446 | :sort-key name | ||
| 447 | :marks ((install . ?I) | ||
| 448 | (upgrade . ?U) | ||
| 449 | (delete . ?D))) | ||
| 450 | |||
| 451 | (defface guix-package-list-obsolete | ||
| 452 | '((t :inherit guix-package-info-obsolete)) | ||
| 453 | "Face used if a package is obsolete." | ||
| 454 | :group 'guix-package-list) | ||
| 455 | |||
| 456 | (defcustom guix-package-list-generation-marking-enabled nil | ||
| 457 | "If non-nil, allow putting marks in a list with 'generation packages'. | ||
| 458 | |||
| 459 | By default this is disabled, because it may be confusing. For | ||
| 460 | example a package is installed in some generation, so a user can | ||
| 461 | mark it for deletion in the list of packages from this | ||
| 462 | generation, but the package may not be installed in the latest | ||
| 463 | generation, so actually it cannot be deleted. | ||
| 464 | |||
| 465 | If you managed to understand the explanation above or if you | ||
| 466 | really know what you do or if you just don't care, you can set | ||
| 467 | this variable to t. It should not do much harm anyway (most | ||
| 468 | likely)." | ||
| 469 | :type 'boolean | ||
| 470 | :group 'guix-package-list) | ||
| 471 | |||
| 472 | (let ((map guix-package-list-mode-map)) | ||
| 473 | (define-key map (kbd "RET") 'guix-package-list-describe) | ||
| 474 | (define-key map (kbd "x") 'guix-package-list-execute) | ||
| 475 | (define-key map (kbd "i") 'guix-package-list-mark-install) | ||
| 476 | (define-key map (kbd "^") 'guix-package-list-mark-upgrade) | ||
| 477 | (define-key map (kbd "d") 'guix-package-list-mark-delete)) | ||
| 478 | |||
| 479 | (defun guix-package-list-get-name (name entry) | ||
| 480 | "Return NAME of the package ENTRY. | ||
| 481 | Colorize it with `guix-package-list-obsolete' if needed." | ||
| 482 | (guix-get-string name | ||
| 483 | (when (guix-get-key-val entry 'obsolete) | ||
| 484 | 'guix-package-list-obsolete))) | ||
| 485 | |||
| 486 | (defun guix-package-list-get-installed-outputs (installed &optional _) | ||
| 487 | "Return string with outputs from INSTALLED entries." | ||
| 488 | (guix-get-string | ||
| 489 | (mapcar (lambda (entry) | ||
| 490 | (guix-get-key-val entry 'output)) | ||
| 491 | installed))) | ||
| 492 | |||
| 493 | (defun guix-package-list-marking-check () | ||
| 494 | "Signal an error if marking is disabled for the current buffer." | ||
| 495 | (when (and (not guix-package-list-generation-marking-enabled) | ||
| 496 | (derived-mode-p 'guix-package-list-mode) | ||
| 497 | (eq guix-search-type 'generation)) | ||
| 498 | (error "Action marks are disabled for lists of 'generation packages'"))) | ||
| 499 | |||
| 500 | (defun guix-package-list-mark-install (&optional arg) | ||
| 501 | "Mark the current package for installation and move to the next line. | ||
| 502 | With ARG, prompt for the outputs to install (several outputs may | ||
| 503 | be separated with \",\")." | ||
| 504 | (interactive "P") | ||
| 505 | (guix-package-list-marking-check) | ||
| 506 | (let* ((entry (guix-list-current-entry)) | ||
| 507 | (available (guix-get-key-val entry 'outputs)) | ||
| 508 | (installed (guix-get-installed-outputs entry)) | ||
| 509 | (to-install (if arg | ||
| 510 | (guix-completing-read-multiple | ||
| 511 | "Output(s) to install: " available nil t) | ||
| 512 | '("out"))) | ||
| 513 | (to-install (cl-set-difference to-install installed | ||
| 514 | :test #'string=))) | ||
| 515 | (if to-install | ||
| 516 | (apply #'guix-list-mark 'install t to-install) | ||
| 517 | (user-error "This package is already installed")))) | ||
| 518 | |||
| 519 | (defun guix-package-list-mark-delete (&optional arg) | ||
| 520 | "Mark the current package for deletion and move to the next line. | ||
| 521 | With ARG, prompt for the outputs to delete (several outputs may | ||
| 522 | be separated with \",\")." | ||
| 523 | (interactive "P") | ||
| 524 | (guix-package-list-marking-check) | ||
| 525 | (let* ((entry (guix-list-current-entry)) | ||
| 526 | (installed (guix-get-installed-outputs entry))) | ||
| 527 | (or installed | ||
| 528 | (user-error "This package is not installed")) | ||
| 529 | (let ((to-delete (when arg | ||
| 530 | (guix-completing-read-multiple | ||
| 531 | "Output(s) to delete: " installed nil t)))) | ||
| 532 | (if to-delete | ||
| 533 | (apply #'guix-list-mark 'delete t to-delete) | ||
| 534 | (guix-package-list-mark-delete-simple))))) | ||
| 535 | |||
| 536 | (defun guix-package-list-mark-upgrade () | ||
| 537 | "Mark the current package for upgrading and move to the next line." | ||
| 538 | (interactive) | ||
| 539 | (guix-package-list-marking-check) | ||
| 540 | (let ((entry (guix-list-current-entry))) | ||
| 541 | (or (guix-get-installed-outputs entry) | ||
| 542 | (user-error "This package is not installed")) | ||
| 543 | (when (or (guix-get-key-val entry 'obsolete) | ||
| 544 | (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) | ||
| 545 | (guix-package-list-mark-upgrade-simple)))) | ||
| 546 | |||
| 547 | (defun guix-package-list-execute () | ||
| 548 | "Perform actions on the marked packages." | ||
| 549 | (interactive) | ||
| 550 | (let ((actions (delq nil | ||
| 551 | (mapcar #'guix-package-list-make-action | ||
| 552 | '(install delete upgrade))))) | ||
| 553 | (if actions | ||
| 554 | (apply #'guix-process-package-actions actions) | ||
| 555 | (user-error "No operations specified")))) | ||
| 556 | |||
| 557 | (defun guix-package-list-make-action (action-type) | ||
| 558 | "Return action specification for the packages marked with ACTION-TYPE. | ||
| 559 | Return nil, if there are no packages marked with ACTION-TYPE. | ||
| 560 | The specification is suitable for `guix-process-package-actions'." | ||
| 561 | (let ((specs (guix-list-get-marked-args action-type))) | ||
| 562 | (and specs (cons action-type specs)))) | ||
| 563 | |||
| 564 | |||
| 565 | ;;; Displaying generations | ||
| 566 | |||
| 567 | (guix-define-buffer-type list generation) | ||
| 568 | |||
| 569 | (guix-list-define-entry-type generation | ||
| 570 | :sort-key number | ||
| 571 | :invert-sort t | ||
| 572 | :marks ((delete . ?D))) | ||
| 573 | |||
| 574 | (let ((map guix-generation-list-mode-map)) | ||
| 575 | (define-key map (kbd "RET") 'guix-generation-list-show-packages) | ||
| 576 | (define-key map (kbd "i") 'guix-generation-list-describe) | ||
| 577 | (define-key map (kbd "d") 'guix-generation-list-mark-delete-simple)) | ||
| 578 | |||
| 579 | (defun guix-generation-list-show-packages () | ||
| 580 | "List installed packages for the generation at point." | ||
| 581 | (interactive) | ||
| 582 | (guix-package-list-get-show 'generation (guix-list-current-id))) | ||
| 583 | |||
| 584 | (provide 'guix-list) | ||
| 585 | |||
| 586 | ;;; guix-list.el ends here | ||
diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm new file mode 100644 index 00000000000..1383d088306 --- /dev/null +++ b/emacs/guix-main.scm | |||
| @@ -0,0 +1,603 @@ | |||
| 1 | ;;; GNU Guix --- Functional package management for GNU | ||
| 2 | ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of GNU Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | ;;; Commentary: | ||
| 20 | |||
| 21 | ;; Information about packages and generations is passed to the elisp | ||
| 22 | ;; side in the form of alists of parameters (such as ‘name’ or | ||
| 23 | ;; ‘version’) and their values. These alists are called "entries" in | ||
| 24 | ;; this code. So to distinguish, just "package" in the name of a | ||
| 25 | ;; function means a guile object ("package" record) while | ||
| 26 | ;; "package entry" means alist of package parameters and values (see | ||
| 27 | ;; ‘package-param-alist’). | ||
| 28 | ;; | ||
| 29 | ;; "Entry" is probably not the best name for such alists, because there | ||
| 30 | ;; already exists "manifest-entry" which has nothing to do with the | ||
| 31 | ;; "entry" described above. Do not be confused :) | ||
| 32 | |||
| 33 | ;; ‘get-entries’ function is the “entry point” for the elisp side to get | ||
| 34 | ;; information about packages and generations. | ||
| 35 | |||
| 36 | ;; Since name/version pair is not necessarily unique, we use | ||
| 37 | ;; `object-address' to identify a package (for ‘id’ parameter), if | ||
| 38 | ;; possible. However for the obsolete packages (that can be found in | ||
| 39 | ;; installed manifest but not in a package directory), ‘id’ parameter is | ||
| 40 | ;; still "name-version" string. So ‘id’ package parameter in the code | ||
| 41 | ;; below is either an object-address number or a full-name string. | ||
| 42 | ;; | ||
| 43 | ;; Important: as object addresses live only during guile session, elisp | ||
| 44 | ;; part should take care about updating information after "Guix REPL" is | ||
| 45 | ;; restarted (TODO!) | ||
| 46 | ;; | ||
| 47 | ;; ‘installed’ parameter of a package entry contains information about | ||
| 48 | ;; installed outputs. It is a list of "installed entries" (see | ||
| 49 | ;; ‘package-installed-param-alist’). | ||
| 50 | |||
| 51 | ;; To speed-up the process of getting information, the following | ||
| 52 | ;; auxiliary variables are used: | ||
| 53 | ;; | ||
| 54 | ;; - `%packages' - VHash of "package address"/"package" pairs. | ||
| 55 | ;; | ||
| 56 | ;; - `%package-table' - Hash table of | ||
| 57 | ;; "name+version key"/"list of packages" pairs. | ||
| 58 | ;; | ||
| 59 | ;; - `%current-manifest-entries-table' - Hash table of | ||
| 60 | ;; "name+version key"/"list of manifest entries" pairs. This variable | ||
| 61 | ;; is set by `set-current-manifest-maybe!' when it is needed. | ||
| 62 | |||
| 63 | ;;; Code: | ||
| 64 | |||
| 65 | (use-modules | ||
| 66 | (ice-9 vlist) | ||
| 67 | (ice-9 match) | ||
| 68 | (srfi srfi-1) | ||
| 69 | (srfi srfi-11) | ||
| 70 | (srfi srfi-19) | ||
| 71 | (srfi srfi-26) | ||
| 72 | (guix) | ||
| 73 | (guix packages) | ||
| 74 | (guix profiles) | ||
| 75 | (guix licenses) | ||
| 76 | (guix utils) | ||
| 77 | (guix ui) | ||
| 78 | (guix scripts package) | ||
| 79 | (gnu packages)) | ||
| 80 | |||
| 81 | (define-syntax-rule (first-or-false lst) | ||
| 82 | (and (not (null? lst)) | ||
| 83 | (first lst))) | ||
| 84 | |||
| 85 | (define full-name->name+version package-name->name+version) | ||
| 86 | (define (name+version->full-name name version) | ||
| 87 | (string-append name "-" version)) | ||
| 88 | |||
| 89 | (define* (make-package-specification name #:optional version output) | ||
| 90 | (let ((full-name (if version | ||
| 91 | (name+version->full-name name version) | ||
| 92 | name))) | ||
| 93 | (if output | ||
| 94 | (string-append full-name ":" output) | ||
| 95 | full-name))) | ||
| 96 | |||
| 97 | (define name+version->key cons) | ||
| 98 | (define key->name+version car+cdr) | ||
| 99 | |||
| 100 | (define %current-manifest #f) | ||
| 101 | (define %current-manifest-entries-table #f) | ||
| 102 | |||
| 103 | (define %packages | ||
| 104 | (fold-packages (lambda (pkg res) | ||
| 105 | (vhash-consq (object-address pkg) pkg res)) | ||
| 106 | vlist-null)) | ||
| 107 | |||
| 108 | (define %package-table | ||
| 109 | (let ((table (make-hash-table (vlist-length %packages)))) | ||
| 110 | (vlist-for-each | ||
| 111 | (lambda (elem) | ||
| 112 | (match elem | ||
| 113 | ((address . pkg) | ||
| 114 | (let* ((key (name+version->key (package-name pkg) | ||
| 115 | (package-version pkg))) | ||
| 116 | (ref (hash-ref table key))) | ||
| 117 | (hash-set! table key | ||
| 118 | (if ref (cons pkg ref) (list pkg))))))) | ||
| 119 | %packages) | ||
| 120 | table)) | ||
| 121 | |||
| 122 | ;; FIXME get rid of this function! | ||
| 123 | (define (set-current-manifest-maybe! profile) | ||
| 124 | (define (manifest-entries->hash-table entries) | ||
| 125 | (let ((entries-table (make-hash-table (length entries)))) | ||
| 126 | (for-each (lambda (entry) | ||
| 127 | (let* ((key (name+version->key | ||
| 128 | (manifest-entry-name entry) | ||
| 129 | (manifest-entry-version entry))) | ||
| 130 | (ref (hash-ref entries-table key))) | ||
| 131 | (hash-set! entries-table key | ||
| 132 | (if ref (cons entry ref) (list entry))))) | ||
| 133 | entries) | ||
| 134 | entries-table)) | ||
| 135 | |||
| 136 | (when profile | ||
| 137 | (let ((manifest (profile-manifest profile))) | ||
| 138 | (unless (and (manifest? %current-manifest) | ||
| 139 | (equal? manifest %current-manifest)) | ||
| 140 | (set! %current-manifest manifest) | ||
| 141 | (set! %current-manifest-entries-table | ||
| 142 | (manifest-entries->hash-table | ||
| 143 | (manifest-entries manifest))))))) | ||
| 144 | |||
| 145 | (define (manifest-entries-by-name+version name version) | ||
| 146 | (or (hash-ref %current-manifest-entries-table | ||
| 147 | (name+version->key name version)) | ||
| 148 | '())) | ||
| 149 | |||
| 150 | (define (packages-by-name+version name version) | ||
| 151 | (or (hash-ref %package-table | ||
| 152 | (name+version->key name version)) | ||
| 153 | '())) | ||
| 154 | |||
| 155 | (define (packages-by-full-name full-name) | ||
| 156 | (call-with-values | ||
| 157 | (lambda () (full-name->name+version full-name)) | ||
| 158 | packages-by-name+version)) | ||
| 159 | |||
| 160 | (define (package-by-address address) | ||
| 161 | (and=> (vhash-assq address %packages) | ||
| 162 | cdr)) | ||
| 163 | |||
| 164 | (define (packages-by-id id) | ||
| 165 | (if (integer? id) | ||
| 166 | (let ((pkg (package-by-address id))) | ||
| 167 | (if pkg (list pkg) '())) | ||
| 168 | (packages-by-full-name id))) | ||
| 169 | |||
| 170 | (define (package-by-id id) | ||
| 171 | (first-or-false (packages-by-id id))) | ||
| 172 | |||
| 173 | (define (newest-package-by-id id) | ||
| 174 | (and=> (id->name+version id) | ||
| 175 | (lambda (name) | ||
| 176 | (first-or-false (find-best-packages-by-name name #f))))) | ||
| 177 | |||
| 178 | (define (id->name+version id) | ||
| 179 | (if (integer? id) | ||
| 180 | (and=> (package-by-address id) | ||
| 181 | (lambda (pkg) | ||
| 182 | (values (package-name pkg) | ||
| 183 | (package-version pkg)))) | ||
| 184 | (full-name->name+version id))) | ||
| 185 | |||
| 186 | (define (fold-manifest-entries proc init) | ||
| 187 | "Fold over `%current-manifest-entries-table'. | ||
| 188 | Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash | ||
| 189 | table, using INIT as the initial value of RESULT." | ||
| 190 | (hash-fold (lambda (key entries res) | ||
| 191 | (let-values (((name version) (key->name+version key))) | ||
| 192 | (proc name version entries res))) | ||
| 193 | init | ||
| 194 | %current-manifest-entries-table)) | ||
| 195 | |||
| 196 | (define (fold-object proc init obj) | ||
| 197 | (fold proc init | ||
| 198 | (if (list? obj) obj (list obj)))) | ||
| 199 | |||
| 200 | (define* (object-transformer param-alist #:optional (params '())) | ||
| 201 | "Return function for transforming an object into alist of parameters/values. | ||
| 202 | |||
| 203 | PARAM-ALIST is alist of available object parameters (symbols) and functions | ||
| 204 | returning values of these parameters. Each function is called with object as | ||
| 205 | a single argument. | ||
| 206 | |||
| 207 | PARAMS is list of parameters from PARAM-ALIST that should be returned by a | ||
| 208 | resulting function. If PARAMS is not specified or is an empty list, use all | ||
| 209 | available parameters. | ||
| 210 | |||
| 211 | Example: | ||
| 212 | |||
| 213 | (let ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>)))) | ||
| 214 | (number->alist (object-transformer alist '(plus1 mul2)))) | ||
| 215 | (number->alist 8)) | ||
| 216 | => | ||
| 217 | ((plus1 . 9) (mul2 . 16)) | ||
| 218 | " | ||
| 219 | (let ((alist (let ((use-all-params (null? params))) | ||
| 220 | (filter-map (match-lambda | ||
| 221 | ((param . fun) | ||
| 222 | (and (or use-all-params | ||
| 223 | (memq param params)) | ||
| 224 | (cons param fun))) | ||
| 225 | (_ #f)) | ||
| 226 | param-alist)))) | ||
| 227 | (lambda (object) | ||
| 228 | (map (match-lambda | ||
| 229 | ((param . fun) | ||
| 230 | (cons param (fun object)))) | ||
| 231 | alist)))) | ||
| 232 | |||
| 233 | (define package-installed-param-alist | ||
| 234 | (list | ||
| 235 | (cons 'output manifest-entry-output) | ||
| 236 | (cons 'path manifest-entry-item) | ||
| 237 | (cons 'dependencies manifest-entry-dependencies))) | ||
| 238 | |||
| 239 | (define manifest-entry->installed-entry | ||
| 240 | (object-transformer package-installed-param-alist)) | ||
| 241 | |||
| 242 | (define (manifest-entries->installed-entries entries) | ||
| 243 | (map manifest-entry->installed-entry entries)) | ||
| 244 | |||
| 245 | (define (installed-entries-by-name+version name version) | ||
| 246 | (manifest-entries->installed-entries | ||
| 247 | (manifest-entries-by-name+version name version))) | ||
| 248 | |||
| 249 | (define (installed-entries-by-package package) | ||
| 250 | (installed-entries-by-name+version (package-name package) | ||
| 251 | (package-version package))) | ||
| 252 | |||
| 253 | (define (package-inputs-names inputs) | ||
| 254 | "Return list of full names of the packages from package INPUTS." | ||
| 255 | (filter-map (match-lambda | ||
| 256 | ((_ (? package? package)) | ||
| 257 | (package-full-name package)) | ||
| 258 | (_ #f)) | ||
| 259 | inputs)) | ||
| 260 | |||
| 261 | (define (package-license-names package) | ||
| 262 | "Return list of license names of the PACKAGE." | ||
| 263 | (fold-object (lambda (license res) | ||
| 264 | (if (license? license) | ||
| 265 | (cons (license-name license) res) | ||
| 266 | res)) | ||
| 267 | '() | ||
| 268 | (package-license package))) | ||
| 269 | |||
| 270 | (define (package-unique? package) | ||
| 271 | "Return #t if PACKAGE is a single package with such name/version." | ||
| 272 | (null? (cdr (packages-by-name+version (package-name package) | ||
| 273 | (package-version package))))) | ||
| 274 | |||
| 275 | (define package-param-alist | ||
| 276 | (list | ||
| 277 | (cons 'id object-address) | ||
| 278 | (cons 'name package-name) | ||
| 279 | (cons 'version package-version) | ||
| 280 | (cons 'license package-license-names) | ||
| 281 | (cons 'synopsis package-synopsis) | ||
| 282 | (cons 'description package-description) | ||
| 283 | (cons 'home-url package-home-page) | ||
| 284 | (cons 'outputs package-outputs) | ||
| 285 | (cons 'non-unique (negate package-unique?)) | ||
| 286 | (cons 'inputs (lambda (pkg) (package-inputs-names | ||
| 287 | (package-inputs pkg)))) | ||
| 288 | (cons 'native-inputs (lambda (pkg) (package-inputs-names | ||
| 289 | (package-native-inputs pkg)))) | ||
| 290 | (cons 'propagated-inputs (lambda (pkg) (package-inputs-names | ||
| 291 | (package-propagated-inputs pkg)))) | ||
| 292 | (cons 'location (lambda (pkg) (location->string | ||
| 293 | (package-location pkg)))) | ||
| 294 | (cons 'installed installed-entries-by-package))) | ||
| 295 | |||
| 296 | (define (package-param package param) | ||
| 297 | "Return the value of a PACKAGE PARAM." | ||
| 298 | (define (accessor param) | ||
| 299 | (and=> (assq param package-param-alist) | ||
| 300 | cdr)) | ||
| 301 | (and=> (accessor param) | ||
| 302 | (cut <> package))) | ||
| 303 | |||
| 304 | (define (matching-package-entries ->entry predicate) | ||
| 305 | "Return list of package entries for the matching packages. | ||
| 306 | PREDICATE is called on each package." | ||
| 307 | (fold-packages (lambda (pkg res) | ||
| 308 | (if (predicate pkg) | ||
| 309 | (cons (->entry pkg) res) | ||
| 310 | res)) | ||
| 311 | '())) | ||
| 312 | |||
| 313 | (define (make-obsolete-package-entry name version entries) | ||
| 314 | "Return package entry for an obsolete package with NAME and VERSION. | ||
| 315 | ENTRIES is a list of manifest entries used to get installed info." | ||
| 316 | `((id . ,(name+version->full-name name version)) | ||
| 317 | (name . ,name) | ||
| 318 | (version . ,version) | ||
| 319 | (outputs . ,(map manifest-entry-output entries)) | ||
| 320 | (obsolete . #t) | ||
| 321 | (installed . ,(manifest-entries->installed-entries entries)))) | ||
| 322 | |||
| 323 | (define (package-entries-by-name+version ->entry name version) | ||
| 324 | "Return list of package entries for packages with NAME and VERSION." | ||
| 325 | (let ((packages (packages-by-name+version name version))) | ||
| 326 | (if (null? packages) | ||
| 327 | (let ((entries (manifest-entries-by-name+version name version))) | ||
| 328 | (if (null? entries) | ||
| 329 | '() | ||
| 330 | (list (make-obsolete-package-entry name version entries)))) | ||
| 331 | (map ->entry packages)))) | ||
| 332 | |||
| 333 | (define (package-entries-by-spec profile ->entry spec) | ||
| 334 | "Return list of package entries for packages with name specification SPEC." | ||
| 335 | (set-current-manifest-maybe! profile) | ||
| 336 | (let-values (((name version) | ||
| 337 | (full-name->name+version spec))) | ||
| 338 | (if version | ||
| 339 | (package-entries-by-name+version ->entry name version) | ||
| 340 | (matching-package-entries | ||
| 341 | ->entry | ||
| 342 | (lambda (pkg) (string=? name (package-name pkg))))))) | ||
| 343 | |||
| 344 | (define (package-entries-by-regexp profile ->entry regexp match-params) | ||
| 345 | "Return list of package entries for packages matching REGEXP string. | ||
| 346 | MATCH-PARAMS is a list of parameters that REGEXP can match." | ||
| 347 | (define (package-match? package regexp) | ||
| 348 | (any (lambda (param) | ||
| 349 | (let ((val (package-param package param))) | ||
| 350 | (and (string? val) (regexp-exec regexp val)))) | ||
| 351 | match-params)) | ||
| 352 | |||
| 353 | (set-current-manifest-maybe! profile) | ||
| 354 | (let ((re (make-regexp regexp regexp/icase))) | ||
| 355 | (matching-package-entries ->entry (cut package-match? <> re)))) | ||
| 356 | |||
| 357 | (define (package-entries-by-ids profile ->entry ids) | ||
| 358 | "Return list of package entries for packages matching KEYS. | ||
| 359 | IDS may be an object-address, a full-name or a list of such elements." | ||
| 360 | (set-current-manifest-maybe! profile) | ||
| 361 | (fold-object | ||
| 362 | (lambda (id res) | ||
| 363 | (if (integer? id) | ||
| 364 | (let ((pkg (package-by-address id))) | ||
| 365 | (if pkg | ||
| 366 | (cons (->entry pkg) res) | ||
| 367 | res)) | ||
| 368 | (let ((entries (package-entries-by-spec #f ->entry id))) | ||
| 369 | (if (null? entries) | ||
| 370 | res | ||
| 371 | (append res entries))))) | ||
| 372 | '() | ||
| 373 | ids)) | ||
| 374 | |||
| 375 | (define (newest-available-package-entries profile ->entry) | ||
| 376 | "Return list of package entries for the newest available packages." | ||
| 377 | (set-current-manifest-maybe! profile) | ||
| 378 | (vhash-fold (lambda (name elem res) | ||
| 379 | (match elem | ||
| 380 | ((version newest pkgs ...) | ||
| 381 | (cons (->entry newest) res)))) | ||
| 382 | '() | ||
| 383 | (find-newest-available-packages))) | ||
| 384 | |||
| 385 | (define (all-available-package-entries profile ->entry) | ||
| 386 | "Return list of package entries for all available packages." | ||
| 387 | (set-current-manifest-maybe! profile) | ||
| 388 | (matching-package-entries ->entry (const #t))) | ||
| 389 | |||
| 390 | (define (manifest-package-entries ->entry) | ||
| 391 | "Return list of package entries for the current manifest." | ||
| 392 | (fold-manifest-entries | ||
| 393 | (lambda (name version entries res) | ||
| 394 | ;; We don't care about duplicates for the list of | ||
| 395 | ;; installed packages, so just take any package (car) | ||
| 396 | ;; matching name+version | ||
| 397 | (cons (car (package-entries-by-name+version ->entry name version)) | ||
| 398 | res)) | ||
| 399 | '())) | ||
| 400 | |||
| 401 | (define (installed-package-entries profile ->entry) | ||
| 402 | "Return list of package entries for all installed packages." | ||
| 403 | (set-current-manifest-maybe! profile) | ||
| 404 | (manifest-package-entries ->entry)) | ||
| 405 | |||
| 406 | (define (generation-package-entries profile ->entry generation) | ||
| 407 | "Return list of package entries for packages from GENERATION." | ||
| 408 | (set-current-manifest-maybe! | ||
| 409 | (generation-file-name profile generation)) | ||
| 410 | (manifest-package-entries ->entry)) | ||
| 411 | |||
| 412 | (define (obsolete-package-entries profile _) | ||
| 413 | "Return list of package entries for obsolete packages." | ||
| 414 | (set-current-manifest-maybe! profile) | ||
| 415 | (fold-manifest-entries | ||
| 416 | (lambda (name version entries res) | ||
| 417 | (let ((packages (packages-by-name+version name version))) | ||
| 418 | (if (null? packages) | ||
| 419 | (cons (make-obsolete-package-entry name version entries) res) | ||
| 420 | res))) | ||
| 421 | '())) | ||
| 422 | |||
| 423 | |||
| 424 | ;;; Generation entries | ||
| 425 | |||
| 426 | (define (profile-generations profile) | ||
| 427 | "Return list of generations for PROFILE." | ||
| 428 | (let ((generations (generation-numbers profile))) | ||
| 429 | (if (equal? generations '(0)) | ||
| 430 | '() | ||
| 431 | generations))) | ||
| 432 | |||
| 433 | (define (generation-param-alist profile) | ||
| 434 | "Return alist of generation parameters and functions for PROFILE." | ||
| 435 | (list | ||
| 436 | (cons 'id identity) | ||
| 437 | (cons 'number identity) | ||
| 438 | (cons 'prev-number (cut previous-generation-number profile <>)) | ||
| 439 | (cons 'path (cut generation-file-name profile <>)) | ||
| 440 | (cons 'time (lambda (gen) | ||
| 441 | (time-second (generation-time profile gen)))))) | ||
| 442 | |||
| 443 | (define (matching-generation-entries profile ->entry predicate) | ||
| 444 | "Return list of generation entries for the matching generations. | ||
| 445 | PREDICATE is called on each generation." | ||
| 446 | (filter-map (lambda (gen) | ||
| 447 | (and (predicate gen) (->entry gen))) | ||
| 448 | (profile-generations profile))) | ||
| 449 | |||
| 450 | (define (last-generation-entries profile ->entry number) | ||
| 451 | "Return list of last NUMBER generation entries. | ||
| 452 | If NUMBER is 0 or less, return all generation entries." | ||
| 453 | (let ((generations (profile-generations profile)) | ||
| 454 | (number (if (<= number 0) +inf.0 number))) | ||
| 455 | (map ->entry | ||
| 456 | (if (> (length generations) number) | ||
| 457 | (list-head (reverse generations) number) | ||
| 458 | generations)))) | ||
| 459 | |||
| 460 | (define (all-generation-entries profile ->entry) | ||
| 461 | "Return list of all generation entries." | ||
| 462 | (last-generation-entries profile ->entry +inf.0)) | ||
| 463 | |||
| 464 | (define (generation-entries-by-ids profile ->entry ids) | ||
| 465 | "Return list of generation entries for generations matching IDS. | ||
| 466 | IDS is a list of generation numbers." | ||
| 467 | (matching-generation-entries profile ->entry (cut memq <> ids))) | ||
| 468 | |||
| 469 | |||
| 470 | ;;; Getting package/generation entries | ||
| 471 | |||
| 472 | (define %package-entries-functions | ||
| 473 | (alist->vhash | ||
| 474 | `((id . ,package-entries-by-ids) | ||
| 475 | (name . ,package-entries-by-spec) | ||
| 476 | (regexp . ,package-entries-by-regexp) | ||
| 477 | (all-available . ,all-available-package-entries) | ||
| 478 | (newest-available . ,newest-available-package-entries) | ||
| 479 | (installed . ,installed-package-entries) | ||
| 480 | (obsolete . ,obsolete-package-entries) | ||
| 481 | (generation . ,generation-package-entries)) | ||
| 482 | hashq)) | ||
| 483 | |||
| 484 | (define %generation-entries-functions | ||
| 485 | (alist->vhash | ||
| 486 | `((id . ,generation-entries-by-ids) | ||
| 487 | (last . ,last-generation-entries) | ||
| 488 | (all . ,all-generation-entries)) | ||
| 489 | hashq)) | ||
| 490 | |||
| 491 | (define (get-entries profile params entry-type search-type search-vals) | ||
| 492 | "Return list of entries. | ||
| 493 | ENTRY-TYPE and SEARCH-TYPE define a search function that should be | ||
| 494 | applied to PARAMS and VALS." | ||
| 495 | (let-values (((vhash ->entry) | ||
| 496 | (case entry-type | ||
| 497 | ((package) | ||
| 498 | (values %package-entries-functions | ||
| 499 | (object-transformer | ||
| 500 | package-param-alist params))) | ||
| 501 | ((generation) | ||
| 502 | (values %generation-entries-functions | ||
| 503 | (object-transformer | ||
| 504 | (generation-param-alist profile) params))) | ||
| 505 | (else (format (current-error-port) | ||
| 506 | "Wrong entry type '~a'" entry-type))))) | ||
| 507 | (match (vhash-assq search-type vhash) | ||
| 508 | ((key . fun) | ||
| 509 | (apply fun profile ->entry search-vals)) | ||
| 510 | (_ '())))) | ||
| 511 | |||
| 512 | |||
| 513 | ;;; Actions | ||
| 514 | |||
| 515 | (define* (package->manifest-entry* package #:optional output) | ||
| 516 | (and package | ||
| 517 | (begin | ||
| 518 | (check-package-freshness package) | ||
| 519 | (package->manifest-entry package output)))) | ||
| 520 | |||
| 521 | (define* (make-install-manifest-entries id #:optional output) | ||
| 522 | (package->manifest-entry* (package-by-id id) output)) | ||
| 523 | |||
| 524 | (define* (make-upgrade-manifest-entries id #:optional output) | ||
| 525 | (package->manifest-entry* (newest-package-by-id id) output)) | ||
| 526 | |||
| 527 | (define* (make-manifest-pattern id #:optional output) | ||
| 528 | "Make manifest pattern from a package ID and OUTPUT." | ||
| 529 | (let-values (((name version) | ||
| 530 | (id->name+version id))) | ||
| 531 | (and name version | ||
| 532 | (manifest-pattern | ||
| 533 | (name name) | ||
| 534 | (version version) | ||
| 535 | (output output))))) | ||
| 536 | |||
| 537 | (define (convert-action-pattern pattern proc) | ||
| 538 | "Convert action PATTERN into a list of objects returned by PROC. | ||
| 539 | PROC is called: (PROC ID) or (PROC ID OUTPUT)." | ||
| 540 | (match pattern | ||
| 541 | ((id . outputs) | ||
| 542 | (if (null? outputs) | ||
| 543 | (let ((obj (proc id))) | ||
| 544 | (if obj (list obj) '())) | ||
| 545 | (filter-map (cut proc id <>) | ||
| 546 | outputs))) | ||
| 547 | (_ '()))) | ||
| 548 | |||
| 549 | (define (convert-action-patterns patterns proc) | ||
| 550 | (append-map (cut convert-action-pattern <> proc) | ||
| 551 | patterns)) | ||
| 552 | |||
| 553 | (define* (process-package-actions | ||
| 554 | profile #:key (install '()) (upgrade '()) (remove '()) | ||
| 555 | (use-substitutes? #t) dry-run?) | ||
| 556 | "Perform package actions. | ||
| 557 | |||
| 558 | INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'. | ||
| 559 | Each pattern should have the following form: | ||
| 560 | |||
| 561 | (ID . OUTPUTS) | ||
| 562 | |||
| 563 | ID is an object address or a full-name of a package. | ||
| 564 | OUTPUTS is a list of package outputs (may be an empty list)." | ||
| 565 | (format #t "The process begins ...~%") | ||
| 566 | (let* ((install (append | ||
| 567 | (convert-action-patterns | ||
| 568 | install make-install-manifest-entries) | ||
| 569 | (convert-action-patterns | ||
| 570 | upgrade make-upgrade-manifest-entries))) | ||
| 571 | (remove (convert-action-patterns remove make-manifest-pattern)) | ||
| 572 | (transaction (manifest-transaction (install install) | ||
| 573 | (remove remove))) | ||
| 574 | (manifest (profile-manifest profile)) | ||
| 575 | (new-manifest (manifest-perform-transaction | ||
| 576 | manifest transaction))) | ||
| 577 | (unless (and (null? install) (null? remove)) | ||
| 578 | (let* ((store (open-connection)) | ||
| 579 | (derivation (run-with-store | ||
| 580 | store (profile-derivation new-manifest))) | ||
| 581 | (derivations (list derivation)) | ||
| 582 | (new-profile (derivation->output-path derivation))) | ||
| 583 | (set-build-options store | ||
| 584 | #:use-substitutes? use-substitutes?) | ||
| 585 | (manifest-show-transaction store manifest transaction | ||
| 586 | #:dry-run? dry-run?) | ||
| 587 | (show-what-to-build store derivations | ||
| 588 | #:use-substitutes? use-substitutes? | ||
| 589 | #:dry-run? dry-run?) | ||
| 590 | (unless dry-run? | ||
| 591 | (let ((name (generation-file-name | ||
| 592 | profile | ||
| 593 | (+ 1 (generation-number profile))))) | ||
| 594 | (and (build-derivations store derivations) | ||
| 595 | (let* ((entries (manifest-entries new-manifest)) | ||
| 596 | (count (length entries))) | ||
| 597 | (switch-symlinks name new-profile) | ||
| 598 | (switch-symlinks profile name) | ||
| 599 | (format #t (N_ "~a package in profile~%" | ||
| 600 | "~a packages in profile~%" | ||
| 601 | count) | ||
| 602 | count))))))))) | ||
| 603 | |||
diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el new file mode 100644 index 00000000000..c1fe1a3a38d --- /dev/null +++ b/emacs/guix-utils.el | |||
| @@ -0,0 +1,160 @@ | |||
| 1 | ;;; guix-utils.el --- General utility functions | ||
| 2 | |||
| 3 | ;; Copyright © 2014 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 '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 face action &optional message | ||
| 88 | &rest properties) | ||
| 89 | "Make button with LABEL and insert it at point. | ||
| 90 | Propertize button with FACE. | ||
| 91 | ACTION is a function called when the button is pressed. It | ||
| 92 | should accept button as the argument. | ||
| 93 | MESSAGE is a button message. | ||
| 94 | See `insert-text-button' for the meaning of PROPERTIES." | ||
| 95 | (if (null label) | ||
| 96 | (guix-format-insert nil) | ||
| 97 | (apply #'insert-text-button | ||
| 98 | label | ||
| 99 | 'face face | ||
| 100 | 'action action | ||
| 101 | 'follow-link t | ||
| 102 | 'help-echo message | ||
| 103 | properties))) | ||
| 104 | |||
| 105 | (defun guix-split-insert (val &optional face col separator) | ||
| 106 | "Convert VAL into a string, split it and insert at point. | ||
| 107 | |||
| 108 | If FACE is non-nil, propertize returned string with this FACE. | ||
| 109 | |||
| 110 | If COL is non-nil and result string is a one-line string longer | ||
| 111 | than COL, split it into several short lines. | ||
| 112 | |||
| 113 | Separate inserted lines with SEPARATOR." | ||
| 114 | (if (null val) | ||
| 115 | (guix-format-insert nil) | ||
| 116 | (let ((strings (guix-split-string (guix-get-string val) col))) | ||
| 117 | (guix-mapinsert (lambda (str) (guix-format-insert str face)) | ||
| 118 | strings | ||
| 119 | (or separator ""))))) | ||
| 120 | |||
| 121 | (defun guix-split-string (str &optional col) | ||
| 122 | "Split string STR by lines and return list of result strings. | ||
| 123 | If COL is non-nil and STR is a one-line string longer than COL, | ||
| 124 | split it into several short lines." | ||
| 125 | (let ((strings (split-string str "\n *"))) | ||
| 126 | (if (and col | ||
| 127 | (null (cdr strings)) ; if not multi-line | ||
| 128 | (> (length str) col)) | ||
| 129 | (split-string (guix-get-filled-string str col) "\n") | ||
| 130 | strings))) | ||
| 131 | |||
| 132 | (defun guix-get-filled-string (str col) | ||
| 133 | "Return string by filling STR to column COL." | ||
| 134 | (with-temp-buffer | ||
| 135 | (insert str) | ||
| 136 | (let ((fill-column col)) | ||
| 137 | (fill-region (point-min) (point-max))) | ||
| 138 | (buffer-string))) | ||
| 139 | |||
| 140 | (defun guix-completing-read-multiple (prompt table &optional predicate | ||
| 141 | require-match initial-input | ||
| 142 | hist def inherit-input-method) | ||
| 143 | "Same as `completing-read-multiple' but remove duplicates in result." | ||
| 144 | (cl-remove-duplicates | ||
| 145 | (completing-read-multiple prompt table predicate | ||
| 146 | require-match initial-input | ||
| 147 | hist def inherit-input-method) | ||
| 148 | :test #'string=)) | ||
| 149 | |||
| 150 | (defun guix-get-key-val (alist &rest keys) | ||
| 151 | "Return value from ALIST by KEYS. | ||
| 152 | ALIST is alist of alists of alists ... which can be consecutively | ||
| 153 | accessed with KEYS." | ||
| 154 | (let ((val alist)) | ||
| 155 | (dolist (key keys val) | ||
| 156 | (setq val (cdr (assq key val)))))) | ||
| 157 | |||
| 158 | (provide 'guix-utils) | ||
| 159 | |||
| 160 | ;;; guix-utils.el ends here | ||
diff --git a/emacs/guix.el b/emacs/guix.el new file mode 100644 index 00000000000..7336f6732e5 --- /dev/null +++ b/emacs/guix.el | |||
| @@ -0,0 +1,141 @@ | |||
| 1 | ;;; guix.el --- Interface for GNU Guix package manager | ||
| 2 | |||
| 3 | ;; Copyright © 2014 Alex Kost <alezost@gmail.com> | ||
| 4 | |||
| 5 | ;; Package-Requires: ((geiser "0.3")) | ||
| 6 | ;; Keywords: tools | ||
| 7 | |||
| 8 | ;; This file is part of GNU Guix. | ||
| 9 | |||
| 10 | ;; GNU Guix is free software; you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Guix is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | |||
| 25 | ;; This package provides an interface for searching, listing and getting | ||
| 26 | ;; information about Guix packages and generations; and for | ||
| 27 | ;; installing/upgrading/removing packages. | ||
| 28 | |||
| 29 | ;;; Code: | ||
| 30 | |||
| 31 | (require 'guix-list) | ||
| 32 | (require 'guix-info) | ||
| 33 | |||
| 34 | (defgroup guix nil | ||
| 35 | "Interface for Guix package manager." | ||
| 36 | :prefix "guix-" | ||
| 37 | :group 'external) | ||
| 38 | |||
| 39 | (defcustom guix-list-single-package nil | ||
| 40 | "If non-nil, list a package even if it is the only matching result. | ||
| 41 | If nil, show a single package in the info buffer." | ||
| 42 | :type 'boolean | ||
| 43 | :group 'guix) | ||
| 44 | |||
| 45 | (defcustom guix-show-generations-function 'guix-generation-list-get-show | ||
| 46 | "Default function used to display generations." | ||
| 47 | :type '(choice (function-item guix-generation-list-get-show) | ||
| 48 | (function-item guix-generation-info-get-show)) | ||
| 49 | :group 'guix) | ||
| 50 | |||
| 51 | (defvar guix-search-params '(name synopsis description) | ||
| 52 | "Default list of package parameters for searching by regexp.") | ||
| 53 | |||
| 54 | (defvar guix-search-history nil | ||
| 55 | "A history of minibuffer prompts.") | ||
| 56 | |||
| 57 | (defun guix-get-show-packages (search-type &rest search-vals) | ||
| 58 | "Search for packages and show results. | ||
| 59 | |||
| 60 | See `guix-get-entries' for the meaning of SEARCH-TYPE and | ||
| 61 | SEARCH-VALS. | ||
| 62 | |||
| 63 | Results are displayed in the list buffer, unless a single package | ||
| 64 | is found and `guix-list-single-package' is nil." | ||
| 65 | (let* ((list-params (guix-package-list-get-params-for-receiving)) | ||
| 66 | (packages (guix-get-entries 'package search-type | ||
| 67 | search-vals list-params))) | ||
| 68 | (if (or guix-list-single-package | ||
| 69 | (cdr packages)) | ||
| 70 | (guix-package-list-set packages search-type search-vals) | ||
| 71 | (let ((info-params (guix-package-info-get-params-for-receiving))) | ||
| 72 | (unless (equal list-params info-params) | ||
| 73 | ;; If we don't have required info, we should receive it again | ||
| 74 | (setq packages (guix-get-entries 'package search-type | ||
| 75 | search-vals info-params)))) | ||
| 76 | (guix-package-info-set packages search-type search-vals)))) | ||
| 77 | |||
| 78 | (defun guix-get-show-generations (search-type &rest search-vals) | ||
| 79 | "Search for generations and show results." | ||
| 80 | (apply guix-show-generations-function search-type search-vals)) | ||
| 81 | |||
| 82 | ;;;###autoload | ||
| 83 | (defun guix-search-by-name (name) | ||
| 84 | "Search for Guix packages by NAME. | ||
| 85 | NAME is a string with name specification. It may optionally contain | ||
| 86 | a version number. Examples: \"guile\", \"guile-2.0.11\"." | ||
| 87 | (interactive | ||
| 88 | (list (read-string "Package name: " nil 'guix-search-history))) | ||
| 89 | (guix-get-show-packages 'name name)) | ||
| 90 | |||
| 91 | ;;;###autoload | ||
| 92 | (defun guix-search-by-regexp (regexp &rest params) | ||
| 93 | "Search for Guix packages by REGEXP. | ||
| 94 | PARAMS are package parameters that should be searched. | ||
| 95 | If PARAMS are not specified, use `guix-search-params'." | ||
| 96 | (interactive | ||
| 97 | (list (read-string "Regexp: " nil 'guix-search-history))) | ||
| 98 | (or params (setq params guix-search-params)) | ||
| 99 | (guix-get-show-packages 'regexp regexp params)) | ||
| 100 | |||
| 101 | ;;;###autoload | ||
| 102 | (defun guix-installed-packages () | ||
| 103 | "Display information about installed Guix packages." | ||
| 104 | (interactive) | ||
| 105 | (guix-get-show-packages 'installed)) | ||
| 106 | |||
| 107 | ;;;###autoload | ||
| 108 | (defun guix-obsolete-packages () | ||
| 109 | "Display information about obsolete Guix packages." | ||
| 110 | (interactive) | ||
| 111 | (guix-get-show-packages 'obsolete)) | ||
| 112 | |||
| 113 | ;;;###autoload | ||
| 114 | (defun guix-all-available-packages () | ||
| 115 | "Display information about all available Guix packages." | ||
| 116 | (interactive) | ||
| 117 | (guix-get-show-packages 'all-available)) | ||
| 118 | |||
| 119 | ;;;###autoload | ||
| 120 | (defun guix-newest-available-packages () | ||
| 121 | "Display information about the newest available Guix packages." | ||
| 122 | (interactive) | ||
| 123 | (guix-get-show-packages 'newest-available)) | ||
| 124 | |||
| 125 | ;;;###autoload | ||
| 126 | (defun guix-generations (&optional number) | ||
| 127 | "Display information about last NUMBER generations. | ||
| 128 | If NUMBER is nil, display all generations. | ||
| 129 | |||
| 130 | Generations can be displayed in a list or info buffers depending | ||
| 131 | on `guix-show-generations-function'. | ||
| 132 | |||
| 133 | Interactively, NUMBER is defined by a numeric prefix." | ||
| 134 | (interactive "P") | ||
| 135 | (if (numberp number) | ||
| 136 | (guix-get-show-generations 'last number) | ||
| 137 | (guix-get-show-generations 'all))) | ||
| 138 | |||
| 139 | (provide 'guix) | ||
| 140 | |||
| 141 | ;;; guix.el ends here | ||
