Merge branch 'master' into core-updates

.gitignore

@@ -105,3 +105,8 @@ GTAGS
 /nix-setuid-helper
 /nix/scripts/guix-authenticate
 /nix/scripts/offload
+/emacs/Makefile.in
+/emacs/Makefile
+/emacs/guix-autoloads.el
+/emacs/guix-helper.scm
+/emacs/guix-init.el

HACKING

@@ -89,6 +89,13 @@ in the form of patches as produced by ‘git format-patch’ sent to
 guix-devel@gnu.org.  Please write commit logs in the [[http://www.gnu.org/prep/standards/html_node/Change-Logs.html#Change-Logs][GNU ChangeLog
 format]]; you can check the commit history for examples.
 
+Before submitting a patch that adds or modifies a package definition, please
+run ‘guix lint PACKAGE’, where PACKAGE is the name of the new or modified
+package, and fix any errors it reports.  In addition, please make sure the
+package builds on your platform, using ‘guix build’.  You may also want to
+check that dependent package (if applicable) are not affected by the change;
+‘guix refresh --list-dependent PACKAGE’ will help you do that.
+
 When posting a patch to the mailing list, use "[PATCH] ..." as a subject.  You
 may use your email client or the ‘git send-mail’ command.
 

Makefile.am

@@ -62,17 +62,14 @@ MODULES =					\
   guix/build/git.scm				\
   guix/build/gnu-build-system.scm		\
   guix/build/gnu-dist.scm			\
-  guix/build/linux-initrd.scm			\
   guix/build/perl-build-system.scm		\
   guix/build/python-build-system.scm		\
+  guix/build/store-copy.scm			\
   guix/build/utils.scm				\
   guix/build/union.scm				\
   guix/build/pull.scm				\
   guix/build/rpath.scm				\
   guix/build/svn.scm				\
-  guix/build/vm.scm				\
-  guix/build/install.scm			\
-  guix/build/activation.scm			\
   guix/build/syscalls.scm			\
   guix/build/emacs-utils.scm			\
   guix/packages.scm				\
@@ -89,6 +86,7 @@ MODULES =					\
   guix/scripts/authenticate.scm			\
   guix/scripts/refresh.scm			\
   guix/scripts/system.scm			\
+  guix/scripts/lint.scm				\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
 
@@ -159,7 +157,8 @@ SCM_TESTS =					\
   tests/nar.scm					\
   tests/union.scm				\
   tests/profiles.scm				\
-  tests/syscalls.scm
+  tests/syscalls.scm				\
+  tests/lint.scm
 
 SH_TESTS =					\
   tests/guix-build.sh				\
@@ -279,6 +278,10 @@ AM_DISTCHECK_CONFIGURE_FLAGS =			\
   --with-nix-prefix="$(NIX_PREFIX)"		\
   --enable-daemon
 
+dist_emacsui_DATA = emacs/guix-main.scm
+nodist_emacsui_DATA = emacs/guix-helper.scm
+include emacs.am
+
 dist-hook: sync-descriptions gen-ChangeLog assert-no-store-file-names
 distcheck-hook: assert-binaries-available assert-final-inputs-self-contained
 

README

@@ -52,19 +52,23 @@ To do so:
   - Install the dependencies (see 'Requirements' above) and build tools using
     Guix:
 
-      guix package --install={autoconf,automake,bzip2,gcc-toolchain,gettext,guile,libgcrypt,pkg-config,sqlite}
+      guix package --install autoconf automake bzip2 gcc-toolchain gettext \
+                             guile libgcrypt pkg-config sqlite
 
-  - set the environment variables that Guix recommends you to set during the
+  - Set the environment variables that Guix recommends you to set during the
     package installation process:
       ACLOCAL_PATH, CPATH, LIBRARY_PATH, PKG_CONFIG_PATH
 
-  - set the PATH environment variable to refer to the profile:
+  - Set the PATH environment variable to refer to the profile:
       PATH=$HOME/.guix-profile/bin:$PATH
 
-  - re-run the configure script passing it the option
-    `--with-libgcrypt-prefix=$HOME/.guix-profile/'
+  - Re-run the 'configure' script passing it the option
+    '--with-libgcrypt-prefix=$HOME/.guix-profile/', as well as
+    '--localstatedir=/somewhere', where '/somewhere' is the 'localstatedir'
+    value of the currently installed Guix (failing to do that would lead the
+    new Guix to consider the store to be empty!).
 
-  - run "make" and "make install"
+  - Run "make", "make check", and "make install".
 
 * How It Works
 

THANKS

@@ -7,6 +7,7 @@ suggestions, bug reports, patches, internationalization, or general
 infrastructure help:
 
 	    Lluís Batlle i Rossell <viric@viric.name>
+         Federico Beffa <beffa@ieee.org>
             Marek Benc <merkur32@gmail.com>
 	   Carlos Carleos <carleos@uniovi.es>
 	   Felipe Castro <fefcas@gmail.com>

config-daemon.ac

@@ -78,10 +78,13 @@ if test "x$guix_build_daemon" = "xyes"; then
   dnl lutimes and lchown: used when canonicalizing store items.
   dnl posix_fallocate: used when extracting archives.
   dnl vfork: to speed up spawning of helper programs.
+  dnl   `--> now disabled because of unpredictable behavior:
+  dnl        see <http://lists.gnu.org/archive/html/guix-devel/2014-05/msg00036.html>
+  dnl        and Nix commit f794465c (Nov. 2012).
   dnl sched_setaffinity: to improve RPC locality.
   dnl statvfs: to detect disk-full conditions.
   dnl strsignal: for error reporting.
-  AC_CHECK_FUNCS([lutimes lchown posix_fallocate vfork sched_setaffinity \
+  AC_CHECK_FUNCS([lutimes lchown posix_fallocate sched_setaffinity \
      statvfs nanosleep strsignal])
 
   dnl Check whether the store optimiser can optimise symlinks.

configure.ac

@@ -174,4 +174,11 @@ AC_CONFIG_FILES([scripts/guix], [chmod +x scripts/guix])
 AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
 AC_CONFIG_FILES([test-env],     [chmod +x test-env])
 
+dnl Emacs interface.
+AM_PATH_LISPDIR
+emacsuidir="${guilemoduledir}/guix/emacs"
+AC_SUBST([emacsuidir])
+AC_CONFIG_FILES([emacs/guix-init.el
+                 emacs/guix-helper.scm])
+
 AC_OUTPUT

doc/emacs.texi

@@ -0,0 +1,321 @@
+@node Emacs Interface
+@section Emacs Interface
+
+@cindex emacs
+GNU Guix comes with a visual user interface for GNU@tie{}Emacs, known
+as ``guix.el''.  It can be used for routine package management tasks,
+pretty much like the @command{guix package} command (@pxref{Invoking
+guix package}).  Specifically, ``guix.el'' makes it easy to:
+
+@itemize
+@item browse and display packages and generations;
+@item search, install, upgrade and remove packages;
+@item display packages from previous generations;
+@item do some other useful things.
+@end itemize
+
+@menu
+* Initial Setup: emacs Initial Setup.	Preparing @file{~/.emacs}.
+* Usage: emacs Usage.			Using the interface.
+* Configuration: emacs Configuration.	Configuring the interface.
+@end menu
+
+@node emacs Initial Setup
+@subsection Initial Setup
+
+To be able to use ``guix.el'', you need to install the following
+packages:
+
+@itemize
+@item
+@uref{http://www.gnu.org/software/emacs/, GNU Emacs}, version 24.3 or
+later;
+
+@item
+@uref{http://nongnu.org/geiser/, Geiser}, version 0.3 or later: it is
+used for interacting with the Guile process.
+
+@end itemize
+
+When it is done, add the following into your init file (@pxref{Init
+File,,, emacs, The Emacs Editor}):
+
+@example
+(require 'guix-init nil t)
+@end example
+
+However there is a chance that @code{load-path} of your Emacs does not
+contain a directory with ``guix.el'' (usually it is
+@file{/usr/share/emacs/site-lisp/}).  In that case you need to add it
+before requiring (@pxref{Lisp Libraries,,, emacs, The Emacs Editor}):
+
+@example
+(add-to-list 'load-path "/path/to/directory-with-guix.el")
+(require 'guix-init)
+@end example
+
+Do not worry about the efficiency of that @code{require} thing.  It will
+not load the whole ``guix.el'' package, it will just autoload the main
+interactive commands (@pxref{Autoload,,, elisp, Emacs Lisp}).
+
+
+@node emacs Usage
+@subsection Usage
+
+Once ``guix.el'' has been successfully configured, you should be able to
+use commands for displaying packages and generations.  This information
+can be displayed in a ``list'' or ``info'' buffer.
+
+@menu
+* Commands: emacs Commands.			@kbd{M-x guix-@dots{}}
+* General information: emacs General info.	Common for both interfaces.
+* ``List'' buffer: emacs List buffer.		List-like interface.
+* ``Info'' buffer: emacs Info buffer.		Help-like interface.
+@end menu
+
+@node emacs Commands
+@subsubsection Commands
+
+You may use the following commands to display packages and generations:
+
+@table @kbd
+@item M-x guix-all-available-packages
+@itemx M-x guix-newest-available-packages
+Display all/newest available packages.
+
+@item M-x guix-installed-packages
+Display all packages installed in the current profile.
+
+@item M-x guix-obsolete-packages
+Display obsolete packages (the packages that are installed in the
+current profile but cannot be found among available packages).
+
+@item M-x guix-search-by-name
+Display package(s) with the specified name.
+
+@item M-x guix-search-by-regexp
+Search for packages by a specified regexp.  By default ``name'',
+``synopsis'' and ``description'' of the packages will be searched.  This
+can be changed by modifying @code{guix-search-params} variable.
+
+@item M-x guix-generations
+List generations for the current profile.  With numeric prefix, show so
+many last generations.
+
+@end table
+
+It is possible to change the currently used profile with
+@kbd{M-x@tie{}guix-set-current-profile}.  This has the same effect as
+specifying @code{--profile} option for @command{guix package}
+(@pxref{Invoking guix package}).
+
+@node emacs General info
+@subsubsection General information
+
+The following keys are available for both ``list'' and ``info'' types of
+buffers:
+
+@table @kbd
+@item l
+@itemx r
+Go backward/forward by the history of the displayed results (this
+history is similar to the history of the Emacs @code{help-mode} or
+@code{Info-mode}).
+
+@item g
+Revert current buffer: update information about the displayed
+packages/generations and redisplay it.
+
+@item R
+Redisplay current buffer (without updating information).
+
+@item C-c C-z
+Go to the Guix REPL (@pxref{The REPL,,, geiser, Geiser User Manual}).
+
+@item h
+@itemx ?
+Describe current mode to see all available bindings.
+
+@end table
+
+@emph{Hint:} If you need several ``list'' or ``info'' buffers, you can
+simlpy @kbd{M-x clone-buffer} them, and each buffer will have its own
+history.
+
+@emph{Warning:} Name/version pairs cannot be used to identify packages
+(because a name is not necessarily unique), so ``guix.el'' uses special
+identifiers that live only during a guile session, so if the Guix REPL
+was restarted, you may want to revert ``list'' buffer (by pressing
+@kbd{g}).
+
+@node emacs List buffer
+@subsubsection ``List'' buffer
+
+An interface of a ``list'' buffer is similar to the interface provided
+by ``package.el'' (@pxref{Package Menu,,, emacs, The Emacs Editor}).
+
+Default key bindings available for both ``package-list'' and
+``generation-list'' buffers:
+
+@table @kbd
+@item m
+Mark the current entry.
+@item M
+Mark all entries.
+@item u
+Unmark the current entry.
+@item @key{DEL}
+Unmark backward.
+@item U
+Unmark all entries.
+@item S
+Sort entries by a specified column.
+@end table
+
+A ``package-list'' buffer additionally provides the following bindings:
+
+@table @kbd
+@item @key{RET}
+Describe marked packages (display available information in a
+``package-info'' buffer).
+@item i
+Mark a package for installation (with prefix, prompt for output(s) to
+install).
+@item d
+Mark a package for deletion.
+@item ^
+Mark a package for upgrading.
+@item x
+Execute actions on marked packages.
+@end table
+
+A ``generation-list'' buffer additionally provides the following
+bindings:
+
+@table @kbd
+@item @key{RET}
+List packages installed in the current generation.
+@item i
+Describe marked generations (display available information in a
+``generation-info'' buffer).
+@end table
+
+@node emacs Info buffer
+@subsubsection ``Info'' buffer
+
+The interface of an ``info'' buffer is similar to the interface of
+@code{help-mode} (@pxref{Help Mode,,, emacs, The Emacs Editor}).
+
+``Info'' buffer contains some buttons (as usual you may use @key{TAB} /
+@kbd{S-@key{TAB}} to move between buttons---@pxref{Mouse References,,,
+emacs, The Emacs Editor}) which can be used to:
+
+@itemize @bullet
+@item (in a ``package-info'' buffer)
+
+@itemize @minus
+@item install/remove a package;
+@item jump to a package location;
+@item browse home page of a package;
+@item describe packages from ``Inputs'' fields.
+@end itemize
+
+@item (in a ``generation-info'' buffer)
+
+@itemize @minus
+@item remove a generation;
+@item list packages installed in a generation;
+@item jump to a generation directory.
+@end itemize
+
+@end itemize
+
+
+@node emacs Configuration
+@subsection Configuration
+
+There are many variables you can modify to change the appearance or
+behavior of Emacs user interface.  Some of these variables are described
+in this section.  Also you can use Custom Interface (@pxref{Easy
+Customization,,, emacs, The Emacs Editor}) to explore/set variables (not
+all) and faces.
+
+@menu
+* Guile and Build Options: emacs Build Options.	Specifying how packages are built.
+* Keymaps: emacs Keymaps.		Configuring key bindings.
+* Appearance: emacs Appearance.		Settings for visual appearance.
+@end menu
+
+@node emacs Build Options
+@subsubsection Guile and Build Options
+
+@table @code
+@item guix-guile-program
+If you have some special needs for starting a Guile process, you may set
+this variable, for example:
+
+@example
+(setq guix-guile-program '("/bin/guile" "--no-auto-compile"))
+@end example
+
+@item guix-use-substitutes
+Has the same meaning as @code{--no-substitutes} option (@pxref{Invoking
+guix build}).
+
+@item guix-dry-run
+Has the same meaning as @code{--dry-run} option (@pxref{Invoking guix
+build}).
+
+@end table
+
+@node emacs Keymaps
+@subsubsection Keymaps
+
+If you want to change default key bindings, use the following keymaps
+(@pxref{Init Rebinding,,, emacs, The Emacs Editor}):
+
+@table @code
+@item guix-list-mode-map
+Parent keymap with general keys for ``list'' buffers.
+
+@item guix-package-list-mode-map
+Keymap with specific keys for ``package-list'' buffers.
+
+@item guix-generation-list-mode-map
+Keymap with specific keys for ``generation-list'' buffers.
+
+@item guix-info-mode-map
+Parent keymap with general keys for ``info'' buffers.
+
+@item guix-package-info-mode-map
+Keymap with specific keys for ``package-info'' buffers.
+
+@item guix-generation-info-mode-map
+Keymap with specific keys for ``generation-info'' buffers.
+
+@end table
+
+@node emacs Appearance
+@subsubsection Appearance
+
+You can change almost any aspect of ``list'' / ``info'' buffers using
+the following variables:
+
+@table @code
+@item guix-list-column-format
+@itemx guix-list-column-titles
+@itemx guix-list-column-value-methods
+Specify the columns, their names, what and how is displayed in ``list''
+buffers.
+
+@item guix-info-displayed-params
+@itemx guix-info-insert-methods
+@itemx guix-info-ignore-empty-vals
+@itemx guix-info-param-title-format
+@itemx guix-info-multiline-prefix
+@itemx guix-info-indent
+@itemx guix-info-fill-column
+@itemx guix-info-delimiter
+Various settings for ``info'' buffers.
+
+@end table

doc/guix.texi

@@ -506,14 +506,16 @@ Unless @code{--lose-logs} is used, all the build logs are kept in the
 @var{localstatedir}.  To save space, the daemon automatically compresses
 them with bzip2 by default.  This option disables that.
 
-@item --disable-store-optimization
+@item --disable-deduplication
+@cindex deduplication
 Disable automatic file ``deduplication'' in the store.
 
 By default, files added to the store are automatically ``deduplicated'':
-if a newly added file is identical as another one found in the store,
-the daemon makes the new file a hard link to the other file.  This
-slightly increases the input/output load at the end of a build process.
-This option disables this.
+if a newly added file is identical to another one found in the store,
+the daemon makes the new file a hard link to the other file.  This can
+noticeably reduce disk usage, at the expense of slightly increasde
+input/output load at the end of a build process.  This option disables
+this optimization.
 
 @item --gc-keep-outputs[=yes|no]
 Tell whether the garbage collector (GC) must keep outputs of live
@@ -579,6 +581,7 @@ management tools it provides.
 @menu
 * Features::                    How Guix will make your life brighter.
 * Invoking guix package::       Package installation, removal, etc.
+* Emacs Interface::             Package management from Emacs.
 * Substitutes::                 Downloading pre-built binaries.
 * Packages with Multiple Outputs::  Single source package, multiple outputs.
 * Invoking guix gc::            Running the garbage collector.
@@ -953,6 +956,8 @@ Finally, since @command{guix package} may actually start build
 processes, it supports all the common build options that @command{guix
 build} supports (@pxref{Invoking guix build, common build options}).
 
+@include emacs.texi
+
 @node Substitutes
 @section Substitutes
 
@@ -1457,7 +1462,10 @@ definitions like the one above may be automatically converted from the
 Nixpkgs distribution using the @command{guix import} command.}, the
 package may actually be built using the @code{guix build} command-line
 tool (@pxref{Invoking guix build}).  @xref{Packaging Guidelines}, for
-more information on how to test package definitions.
+more information on how to test package definitions, and
+@ref{Invoking guix lint}, for information on how to check a definition
+for style conformance.
+
 
 Eventually, updating the package definition to a new upstream version
 can be partly automated by the @command{guix refresh} command
@@ -2270,6 +2278,22 @@ search path to be copied in the store, compiled, and made available in
 the load path during the execution of @var{exp}---e.g., @code{((guix
 build utils) (guix build gnu-build-system))}.
 
+When @var{references-graphs} is true, it must be a list of tuples of one of the
+following forms:
+
+@example
+(@var{file-name} @var{package})
+(@var{file-name} @var{package} @var{output})
+(@var{file-name} @var{derivation})
+(@var{file-name} @var{derivation} @var{output})
+(@var{file-name} @var{store-item})
+@end example
+
+The right-hand-side of each element of @var{references-graphs} is automatically made
+an input of the build process of @var{exp}.  In the build environment, each
+@var{file-name} contains the reference graph of the corresponding item, in a simple
+text format.
+
 The other arguments are as for @code{derivation} (@pxref{Derivations}).
 @end deffn
 
@@ -2326,6 +2350,7 @@ programming interface of Guix in a convenient way.
 * Invoking guix download::      Downloading a file and printing its hash.
 * Invoking guix hash::          Computing the cryptographic hash of a file.
 * Invoking guix refresh::       Updating package definitions.
+* Invoking guix lint::          Finding errors in package definitions.
 @end menu
 
 @node Invoking guix build
@@ -2703,6 +2728,29 @@ for in @code{$PATH}.
 
 @end table
 
+@node Invoking guix lint
+@section Invoking @command{guix lint}
+The @command{guix lint} is meant to help package developers avoid common
+errors and use a consistent style.  It runs a few checks on a given set of
+packages in order to find common mistakes in their definitions.
+
+The general syntax is:
+
+@example
+guix lint @var{options} @var{package}@dots{}
+@end example
+
+If no package is given on the command line, then all packages are checked.
+The @var{options} may be zero or more of the following:
+
+@table @code
+
+@item --list-checkers
+@itemx -l
+List and describe all the available checkers that will be run on packages
+and exit.
+
+@end table
 
 @c *********************************************************************
 @node GNU Distribution
@@ -2946,7 +2994,7 @@ more information, @pxref{Invoking guix system}.  This command may trigger
 downloads or builds of missing packages, which can take some time.
 
 Once that command has completed---and hopefully succeeded!---you can
-unmount @file{/mnt} and boot into the new system.  Cross fingers, and
+run @command{reboot} and boot into the new system.  Cross fingers, and
 join us on @code{#guix} on the Freenode IRC network or on
 @file{guix-devel@@gnu.org} to share your experience---good or not so
 good.
@@ -3533,6 +3581,10 @@ system declaration like this:
              #:extra-modules '("my.ko" "modules.ko")))
 @end example
 
+@noindent
+Note that for the example above, the SRFI-26 module needs to be imported
+(@pxref{SRFI-26,,, guile, GNU Guile Reference Manual}).
+
 It also handles common use cases that involves using the system as a
 QEMU guest, or as a ``live'' system whose root file system is volatile.
 

emacs.am

@@ -0,0 +1,43 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2014 Alex Kost <alezost@gmail.com>
+#
+# This file is part of GNU Guix.
+#
+# GNU Guix is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# GNU Guix is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+AUTOLOADS = emacs/guix-autoloads.el
+
+ELFILES =					\
+  emacs/guix-backend.el				\
+  emacs/guix-base.el				\
+  emacs/guix-history.el				\
+  emacs/guix-info.el				\
+  emacs/guix-list.el				\
+  emacs/guix-utils.el				\
+  emacs/guix.el
+
+dist_lisp_DATA =				\
+  $(ELFILES)					\
+  $(AUTOLOADS)
+
+nodist_lisp_DATA =				\
+  emacs/guix-init.el
+
+$(AUTOLOADS): $(ELFILES)
+	$(EMACS) --batch --eval						\
+	  "(let ((backup-inhibited t)					\
+	         (generated-autoload-file				\
+	          (expand-file-name \"$(AUTOLOADS)\" \"$(srcdir)\")))	\
+	     (update-directory-autoloads				\
+	      (expand-file-name \"emacs\" \"$(srcdir)\")))"

emacs/guix-backend.el

@@ -0,0 +1,301 @@
+;;; guix-backend.el --- Communication with Geiser
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the code for interacting with Guile using Geiser.
+
+;; By default (if `guix-use-guile-server' is non-nil) 2 Geiser REPLs are
+;; started.  The main one (with "guile --listen" process) is used for
+;; "interacting" with a user - for showing a progress of
+;; installing/deleting Guix packages.  The second (internal) REPL is
+;; used for synchronous evaluating, e.g. when information about
+;; packages/generations should be received for a list/info buffer.
+;;
+;; This "2 REPLs concept" makes it possible to have a running process of
+;; installing/deleting packages and to continue to search/list/get info
+;; about other packages at the same time.  If you prefer to use a single
+;; Guix REPL, do not try to receive any information while there is a
+;; running code in the REPL (see
+;; <https://github.com/jaor/geiser/issues/28>).
+;;
+;; If you need to use "guix.el" in another Emacs (i.e. when there is
+;; a runnig "guile --listen..." REPL somewhere), you can either change
+;; `guix-default-port' in that Emacs instance or set
+;; `guix-use-guile-server' to t.
+;;
+;; Guix REPLs (unlike the usual Geiser REPLs) are not added to
+;; `geiser-repl--repls' variable, and thus cannot be used for evaluating
+;; while editing scm-files.  The only purpose of Guix REPLs is to be an
+;; intermediate between "Guix/Guile level" and "Emacs interface level".
+;; That being said you can still want to use a Guix REPL while hacking
+;; auxiliary scheme-files for "guix.el".  You can just use "M-x
+;; connect-to-guile" (connect to "localhost" and `guix-default-port') to
+;; have a usual Geiser REPL with all stuff defined by "guix.el" package.
+
+;;; Code:
+
+(require 'geiser-mode)
+
+(defvar guix-load-path
+  (file-name-directory (or load-file-name
+                           (locate-library "guix")))
+  "Directory with scheme files for \"guix.el\" package.")
+
+(defvar guix-helper-file
+  (expand-file-name "guix-helper.scm" guix-load-path)
+  "Auxiliary scheme file for loading.")
+
+(defvar guix-guile-program (or geiser-guile-binary "guile")
+  "Name of the guile executable used for Guix REPL.
+May be either a string (the name of the executable) or a list of
+strings of the form:
+
+  (NAME . ARGS)
+
+Where ARGS is a list of arguments to the guile program.")
+
+
+;;; REPL
+
+(defgroup guix-repl nil
+  "Settings for Guix REPLs."
+  :prefix "guix-repl-"
+  :group 'guix)
+
+(defcustom guix-repl-startup-time 30000
+  "Time, in milliseconds, to wait for Guix REPL to startup.
+Same as `geiser-repl-startup-time' but is used for Guix REPL.
+If you have a slow system, try to increase this time."
+  :type 'integer
+  :group 'guix-repl)
+
+(defcustom guix-repl-buffer-name "*Guix REPL*"
+  "Default name of a Geiser REPL buffer used for Guix."
+  :type 'string
+  :group 'guix-repl)
+
+(defcustom guix-after-start-repl-hook ()
+  "Hook called after Guix REPL is started."
+  :type 'hook
+  :group 'guix-repl)
+
+(defcustom guix-use-guile-server t
+  "If non-nil, start guile with '--listen' argument.
+This allows to receive information about packages using an additional
+REPL while some packages are being installed/removed in the main REPL."
+  :type 'boolean
+  :group 'guix-repl)
+
+(defcustom guix-default-port 37246
+  "Default port used if `guix-use-guile-server' is non-nil."
+  :type 'integer
+  :group 'guix-repl)
+
+(defvar guix-repl-buffer nil
+  "Main Geiser REPL buffer used for communicating with Guix.
+This REPL is used for processing package actions and for
+receiving information if `guix-use-guile-server' is nil.")
+
+(defvar guix-internal-repl-buffer nil
+  "Additional Geiser REPL buffer used for communicating with Guix.
+This REPL is used for receiving information only if
+`guix-use-guile-server' is non-nil.")
+
+(defvar guix-internal-repl-buffer-name "*Guix Internal REPL*"
+  "Default name of an internal Guix REPL buffer.")
+
+(defun guix-get-guile-program (&optional internal)
+  "Return a value suitable for `geiser-guile-binary'."
+  (if (or internal
+          (not guix-use-guile-server))
+      guix-guile-program
+    (append (if (listp guix-guile-program)
+                guix-guile-program
+              (list guix-guile-program))
+            ;; Guile understands "--listen=..." but not "--listen ..."
+            (list (concat "--listen="
+                          (number-to-string guix-default-port))))))
+
+(defun guix-start-process-maybe ()
+  "Start Geiser REPL configured for Guix if needed."
+  (guix-start-repl-maybe)
+  (if guix-use-guile-server
+      (guix-start-repl-maybe 'internal)
+    (setq guix-internal-repl-buffer guix-repl-buffer)))
+
+(defun guix-start-repl-maybe (&optional internal)
+  "Start Guix REPL if needed.
+If INTERNAL is non-nil, start an internal REPL."
+  (let* ((repl-var (guix-get-repl-buffer-variable internal))
+         (repl (symbol-value repl-var)))
+    (unless (and (buffer-live-p repl)
+                 (get-buffer-process repl))
+      ;; Kill REPL buffer with a dead process
+      (and (buffer-live-p repl) (kill-buffer repl))
+      (or internal
+          (message "Starting Geiser REPL for Guix ..."))
+      (let ((geiser-guile-binary (guix-get-guile-program internal))
+            (geiser-guile-init-file (or internal guix-helper-file))
+            (repl (get-buffer-create
+                   (guix-get-repl-buffer-name internal))))
+        (condition-case err
+            (guix-start-repl repl
+                             (and internal
+                                  (geiser-repl--read-address
+                                   "localhost" guix-default-port)))
+          (text-read-only
+           (error (concat "Couldn't start Guix REPL.  Perhaps the port %s is busy.\n"
+                          "See buffer '%s' for details")
+                  guix-default-port (buffer-name repl))))
+        (set repl-var repl)
+        (unless internal
+          (message "Guix REPL has been started.")
+          (run-hooks 'guix-after-start-repl-hook))))))
+
+(defun guix-start-repl (buffer &optional address)
+  "Start Guix REPL in BUFFER.
+If ADDRESS is non-nil, connect to a remote guile process using
+this address (it should be defined by
+`geiser-repl--read-address')."
+  ;; A mix of the code from `geiser-repl--start-repl' and
+  ;; `geiser-repl--to-repl-buffer'.
+  (let ((impl 'guile)
+        (geiser-guile-load-path (list guix-load-path))
+        (geiser-repl-startup-time guix-repl-startup-time))
+    (with-current-buffer buffer
+      (geiser-repl-mode)
+      (geiser-impl--set-buffer-implementation impl)
+      (geiser-repl--autodoc-mode -1)
+      (goto-char (point-max))
+      (let* ((prompt-re (geiser-repl--prompt-regexp impl))
+             (deb-prompt-re (geiser-repl--debugger-prompt-regexp impl))
+             (prompt (geiser-con--combined-prompt prompt-re deb-prompt-re)))
+        (or prompt-re
+            (error "Oh no! Guix REPL in the buffer '%s' has not been started"
+                   (buffer-name buffer)))
+        (geiser-repl--save-remote-data address)
+        (geiser-repl--start-scheme impl address prompt)
+        (geiser-repl--quit-setup)
+        (geiser-repl--history-setup)
+        (setq-local geiser-repl--repls (list buffer))
+        (geiser-repl--set-this-buffer-repl buffer)
+        (setq geiser-repl--connection
+              (geiser-con--make-connection
+               (get-buffer-process (current-buffer))
+               prompt-re
+               deb-prompt-re))
+        (geiser-repl--startup impl address)
+        (geiser-repl--autodoc-mode 1)
+        (geiser-company--setup geiser-repl-company-p)
+        (add-hook 'comint-output-filter-functions
+                  'geiser-repl--output-filter
+                  nil t)
+        (set-process-query-on-exit-flag
+         (get-buffer-process (current-buffer))
+         geiser-repl-query-on-kill-p)))))
+
+(defun guix-get-repl-buffer (&optional internal)
+  "Return Guix REPL buffer; start REPL if needed.
+If INTERNAL is non-nil, return an additional internal REPL."
+  (guix-start-process-maybe)
+  (let ((repl (symbol-value (guix-get-repl-buffer-variable internal))))
+    ;; If a new Geiser REPL is started, `geiser-repl--repl' variable may
+    ;; be set to the new value in a Guix REPL, so set it back to a
+    ;; proper value here.
+    (with-current-buffer repl
+      (geiser-repl--set-this-buffer-repl repl))
+    repl))
+
+(defun guix-get-repl-buffer-variable (&optional internal)
+  "Return the name of a variable with a REPL buffer."
+  (if internal
+      'guix-internal-repl-buffer
+    'guix-repl-buffer))
+
+(defun guix-get-repl-buffer-name (&optional internal)
+  "Return the name of a REPL buffer."
+  (if internal
+      guix-internal-repl-buffer-name
+    guix-repl-buffer-name))
+
+(defun guix-switch-to-repl (&optional internal)
+  "Switch to Guix REPL.
+If INTERNAL is non-nil (interactively with prefix), switch to the
+additional internal REPL if it exists."
+  (interactive "P")
+  (geiser-repl--switch-to-buffer (guix-get-repl-buffer internal)))
+
+
+;;; Evaluating expressions
+
+(defun guix-make-guile-expression (fun &rest args)
+  "Return string containing a guile expression for calling FUN with ARGS."
+  (format "(%S %s)" fun
+          (mapconcat
+           (lambda (arg)
+             (cond
+              ((null arg) "'()")
+              ((or (eq arg t)
+                   ;; An ugly hack to separate 'false' from nil
+                   (equal arg 'f)
+                   (keywordp arg))
+               (concat "#" (prin1-to-string arg t)))
+              ((or (symbolp arg) (listp arg))
+               (concat "'" (prin1-to-string arg)))
+              (t (prin1-to-string arg))))
+           args
+           " ")))
+
+(defun guix-eval (str &optional wrap)
+  "Evaluate guile expression STR.
+If WRAP is non-nil, wrap STR into (begin ...) form.
+Return a list of strings with result values of evaluation."
+  (with-current-buffer (guix-get-repl-buffer 'internal)
+    (let* ((wrapped (if wrap (geiser-debug--wrap-region str) str))
+           (code `(:eval (:scm ,wrapped)))
+           (ret (geiser-eval--send/wait code)))
+      (if (geiser-eval--retort-error ret)
+          (error "Error in evaluating guile expression: %s"
+                 (geiser-eval--retort-output ret))
+        (cdr (assq 'result ret))))))
+
+(defun guix-eval-read (str &optional wrap)
+  "Evaluate guile expression STR.
+For the meaning of WRAP, see `guix-eval'.
+Return elisp expression of the first result value of evaluation."
+  ;; Parsing scheme code with elisp `read' is probably not the best idea.
+  (read (replace-regexp-in-string
+         "#f\\|#<unspecified>" "nil"
+         (replace-regexp-in-string
+          "#t" "t" (car (guix-eval str wrap))))))
+
+(defun guix-eval-in-repl (str)
+  "Switch to Guix REPL and evaluate STR with guile expression there."
+  (let ((repl (guix-get-repl-buffer)))
+    (with-current-buffer repl
+      (delete-region (geiser-repl--last-prompt-end) (point-max))
+      (goto-char (point-max))
+      (insert str)
+      (geiser-repl--send-input))
+    (geiser-repl--switch-to-buffer repl)))
+
+(provide 'guix-backend)
+
+;;; guix-backend.el ends here

emacs/guix-base.el

@@ -0,0 +1,607 @@
+;;; guix-base.el --- Common definitions
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides some base and common definitions for guix.el
+;; package.
+
+;; List and info buffers have many common patterns that are defined
+;; using `guix-define-buffer-type' macro from this file.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'guix-backend)
+(require 'guix-utils)
+
+
+;;; Profiles
+
+(defvar guix-user-profile
+  (expand-file-name "~/.guix-profile")
+  "User profile.")
+
+(defvar guix-default-profile
+  (concat (or (getenv "NIX_STATE_DIR") "/var/guix")
+          "/profiles/per-user/"
+          (getenv "USER")
+          "/guix-profile")
+  "Default Guix profile.")
+
+(defvar guix-current-profile guix-default-profile
+  "Current profile.")
+
+(defun guix-set-current-profile (path)
+  "Set `guix-current-profile' to PATH.
+Interactively, prompt for PATH.  With prefix, use
+`guix-default-profile'."
+  (interactive
+   (list (if current-prefix-arg
+             guix-default-profile
+           (read-file-name "Set profile: "
+                           (file-name-directory guix-current-profile)))))
+  (let ((path (directory-file-name (expand-file-name path))))
+    (setq guix-current-profile
+          (if (string= path guix-user-profile)
+              guix-default-profile
+            path))
+    (message "Current profile has been set to '%s'."
+             guix-current-profile)))
+
+
+;;; Parameters of the entries
+
+(defvar guix-param-titles
+  '((package
+     (id                . "ID")
+     (name              . "Name")
+     (version           . "Version")
+     (license           . "License")
+     (synopsis          . "Synopsis")
+     (description       . "Description")
+     (home-url          . "Home page")
+     (outputs           . "Outputs")
+     (inputs            . "Inputs")
+     (native-inputs     . "Native inputs")
+     (propagated-inputs . "Propagated inputs")
+     (location          . "Location")
+     (installed         . "Installed"))
+    (installed
+     (path              . "Installed path")
+     (dependencies      . "Dependencies")
+     (output            . "Output"))
+    (generation
+     (id                . "ID")
+     (number            . "Number")
+     (prev-number       . "Previous number")
+     (path              . "Path")
+     (time              . "Time")))
+  "List for defining titles of entry parameters.
+Titles are used for displaying information about entries.
+Each element of the list has a form:
+
+  (ENTRY-TYPE . ((PARAM . TITLE) ...))")
+
+(defun guix-get-param-title (entry-type param)
+  "Return title of an ENTRY-TYPE entry parameter PARAM."
+  (or (guix-get-key-val guix-param-titles
+                        entry-type param)
+      (prog1 (symbol-name param)
+        (message "Couldn't find title for '%S %S'."
+                 entry-type param))))
+
+(defun guix-get-name-spec (name version &optional output)
+  "Return Guix package specification by its NAME, VERSION and OUTPUT."
+  (concat name "-" version
+          (when output (concat ":" output))))
+
+(defun guix-get-full-name (entry &optional output)
+  "Return name specification of the package ENTRY and OUTPUT."
+  (guix-get-name-spec (guix-get-key-val entry 'name)
+                      (guix-get-key-val entry 'version)
+                      output))
+
+(defun guix-get-installed-outputs (entry)
+  "Return list of installed outputs for the package ENTRY."
+  (mapcar (lambda (installed-entry)
+            (guix-get-key-val installed-entry 'output))
+          (guix-get-key-val entry 'installed)))
+
+(defun guix-get-entry-by-id (id entries)
+  "Return entry from ENTRIES by entry ID."
+  (cl-find-if (lambda (entry)
+                (equal id (guix-get-key-val entry 'id)))
+              entries))
+
+
+;;; Location of the packages
+
+(defvar guix-directory nil
+  "Default Guix directory.
+If it is not set by a user, it is set after starting Guile REPL.
+This directory is used to define location of the packages.")
+
+(defun guix-set-directory ()
+  "Set `guix-directory' if needed."
+  (or guix-directory
+      (setq guix-directory
+            (guix-eval-read "%guix-dir"))))
+
+(add-hook 'guix-after-start-repl-hook 'guix-set-directory)
+
+(defun guix-find-location (location)
+  "Go to LOCATION of a package.
+LOCATION is a string of the form:
+
+  \"PATH:LINE:COLUMN\"
+
+If PATH is relative, it is considered to be relative to
+`guix-directory'."
+  (cl-multiple-value-bind (path line col)
+      (split-string location ":")
+    (let ((file (expand-file-name path guix-directory))
+          (line (string-to-number line))
+          (col  (string-to-number col)))
+      (find-file file)
+      (goto-char (point-min))
+      (forward-line (- line 1))
+      (move-to-column col)
+      (recenter 1))))
+
+
+;;; Common definitions for buffer types
+
+(defvar-local guix-entries nil
+  "List of the currently displayed entries.
+Each element of the list is alist with entry info of the
+following form:
+
+  ((PARAM . VAL) ...)
+
+PARAM is a name of the entry parameter.
+VAL is a value of this parameter.")
+(put 'guix-entries 'permanent-local t)
+
+(defvar-local guix-search-type nil
+  "Type of the current search.")
+(put 'guix-search-type 'permanent-local t)
+
+(defvar-local guix-search-vals nil
+  "Values of the current search.")
+(put 'guix-search-vals 'permanent-local t)
+
+(defsubst guix-set-vars (entries search-type search-vals)
+  (setq guix-entries entries
+        guix-search-type search-type
+        guix-search-vals search-vals))
+
+(defmacro guix-define-buffer-type (buf-type entry-type &rest args)
+  "Define common stuff for BUF-TYPE buffers for displaying entries.
+
+ENTRY-TYPE is a type of displayed entries (see
+`guix-get-entries').
+
+In the text below TYPE means ENTRY-TYPE-BUF-TYPE.
+
+This macro defines `guix-TYPE-mode', a custom group, several user
+variables and the following functions:
+
+  - `guix-TYPE-get-params-for-receiving'
+  - `guix-TYPE-revert'
+  - `guix-TYPE-redisplay'
+  - `guix-TYPE-make-history-item'
+  - `guix-TYPE-set'
+  - `guix-TYPE-show'
+  - `guix-TYPE-get-show'
+
+The following stuff should be defined outside this macro:
+
+  - `guix-BUF-TYPE-mode' - parent mode for the defined mode.
+
+  - `guix-BUF-TYPE-insert-entries' - function for inserting
+  entries in the current buffer; it is called with 2 arguments:
+  entries of the form of `guix-entries' and ENTRY-TYPE.
+
+  - `guix-BUF-TYPE-get-displayed-params' - function returning a
+  list of parameters displayed in the current buffer; it is
+  called with ENTRY-TYPE as argument.
+
+  - `guix-TYPE-mode-initialize' (optional) - function for
+  additional mode settings; it is called without arguments.
+
+Remaining argument (ARGS) should have a form [KEYWORD VALUE] ...  The
+following keywords are available:
+
+  - `:required' - default value for the defined
+    `guix-TYPE-required-params' variable.
+
+  - `:history-size' - default value for the defined
+    `guix-TYPE-history-size' variable.
+
+  - `:revert' - default value for the defined
+    `guix-TYPE-revert-no-confirm' variable."
+  (let* ((entry-type-str (symbol-name entry-type))
+         (buf-type-str   (symbol-name buf-type))
+         (Entry-type-str (capitalize entry-type-str))
+         (Buf-type-str   (capitalize buf-type-str))
+         (entry-str      (concat entry-type-str " entries"))
+         (buf-str        (concat buf-type-str " buffer"))
+         (prefix         (concat "guix-" entry-type-str "-" buf-type-str))
+         (group          (intern prefix))
+         (mode-map-str   (concat prefix "-mode-map"))
+         (mode-map       (intern mode-map-str))
+         (parent-mode    (intern (concat "guix-" buf-type-str "-mode")))
+         (mode           (intern (concat prefix "-mode")))
+         (mode-init-fun  (intern (concat prefix "-mode-initialize")))
+         (buf-name-var   (intern (concat prefix "-buffer-name")))
+         (revert-var     (intern (concat prefix "-revert-no-confirm")))
+         (revert-fun     (intern (concat prefix "-revert")))
+         (redisplay-fun  (intern (concat prefix "-redisplay")))
+         (history-var    (intern (concat prefix "-history-size")))
+         (history-fun    (intern (concat prefix "-make-history-item")))
+         (params-var     (intern (concat prefix "-required-params")))
+         (params-fun     (intern (concat prefix "-get-params-for-receiving")))
+         (set-fun        (intern (concat prefix "-set")))
+         (show-fun       (intern (concat prefix "-show")))
+         (get-show-fun   (intern (concat prefix "-get-show")))
+         (revert-val     nil)
+         (history-val    20)
+         (params-val     '(id)))
+
+    ;; Process the keyword args.
+    (while (keywordp (car args))
+      (pcase (pop args)
+	(`:required     (setq params-val (pop args)))
+	(`:history-size (setq history-val (pop args)))
+	(`:revert       (setq revert-val (pop args)))
+	(_ (pop args))))
+
+    `(progn
+       (defgroup ,group nil
+         ,(concat Buf-type-str " buffer with " entry-str ".")
+         :prefix ,(concat prefix "-")
+         :group ',(intern (concat "guix-" buf-type-str)))
+
+       (defcustom ,buf-name-var ,(format "*Guix %s %s*"
+                                         Entry-type-str Buf-type-str)
+         ,(concat "Default name of the " buf-str " for displaying " entry-str ".")
+         :type 'string
+         :group ',group)
+
+       (defcustom ,history-var ,history-val
+         ,(concat "Maximum number of items saved in the history of the " buf-str ".\n"
+                  "If 0, the history is disabled.")
+         :type 'integer
+         :group ',group)
+
+       (defcustom ,revert-var ,revert-val
+         ,(concat "If non-nil, do not ask to confirm for reverting the " buf-str ".")
+         :type 'boolean
+         :group ',group)
+
+       (defvar ,params-var ',params-val
+         ,(concat "List of required " entry-type-str " parameters.\n\n"
+                  "Displayed parameters and parameters from this list are received\n"
+                  "for each " entry-type-str ".\n\n"
+                  "May be a special value `all', in which case all supported\n"
+                  "parameters are received (this may be very slow for a big number\n"
+                  "of entries).\n\n"
+                  "Do not remove `id' from this list as it is required for\n"
+                  "identifying an entry."))
+
+       (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str)
+         ,(concat "Major mode for displaying information about " entry-str ".\n\n"
+                  "\\{" mode-map-str "}")
+         (setq-local revert-buffer-function ',revert-fun)
+         (setq-local guix-history-size ,history-var)
+         (and (fboundp ',mode-init-fun) (,mode-init-fun)))
+
+       (let ((map ,mode-map))
+         (define-key map (kbd "l") 'guix-history-back)
+         (define-key map (kbd "r") 'guix-history-forward)
+         (define-key map (kbd "g") 'revert-buffer)
+         (define-key map (kbd "R") ',redisplay-fun)
+         (define-key map (kbd "C-c C-z") 'guix-switch-to-repl))
+
+       (defun ,params-fun ()
+         ,(concat "Return " entry-type-str " parameters that should be received.")
+         (unless (equal ,params-var 'all)
+           (cl-union ,params-var
+                     (,(intern (concat "guix-" buf-type-str "-get-displayed-params"))
+                      ',entry-type))))
+
+       (defun ,revert-fun (_ignore-auto noconfirm)
+         "Update information in the current buffer.
+The function is suitable for `revert-buffer-function'.
+See `revert-buffer' for the meaning of NOCONFIRM."
+         (when (or ,revert-var
+                   noconfirm
+                   (y-or-n-p "Update current information? "))
+           (let ((entries (guix-get-entries ',entry-type guix-search-type
+                                            guix-search-vals (,params-fun))))
+             (,set-fun entries guix-search-type guix-search-vals t))))
+
+       (defun ,redisplay-fun ()
+         "Redisplay current information.
+This function will not update the information, use
+\"\\[revert-buffer]\" if you want the full update."
+         (interactive)
+         (,show-fun guix-entries)
+         (guix-result-message guix-entries ',entry-type
+                              guix-search-type guix-search-vals))
+
+       (defun ,history-fun ()
+         "Make and return a history item for the current buffer."
+         (list (lambda (entries search-type search-vals)
+                 (,show-fun entries)
+                 (guix-set-vars entries search-type search-vals)
+                 (guix-result-message entries ',entry-type
+                                      search-type search-vals))
+               guix-entries guix-search-type guix-search-vals))
+
+       (defun ,set-fun (entries search-type search-vals &optional history-replace)
+         ,(concat "Set up the " buf-str " for displaying " entry-str ".\n\n"
+                  "Display ENTRIES, set variables and make history item.\n\n"
+                  "ENTRIES should have a form of `guix-entries'.\n\n"
+                  "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n"
+                  "SEARCH-VALS.\n\n"
+                  "If HISTORY-REPLACE is non-nil, replace current history item,\n"
+                  "otherwise add the new one.")
+         (when entries
+           (let ((buf (if (eq major-mode ',mode)
+                          (current-buffer)
+                        (get-buffer-create ,buf-name-var))))
+             (with-current-buffer buf
+               (,show-fun entries)
+               (guix-set-vars entries search-type search-vals)
+               (funcall (if history-replace
+                            #'guix-history-replace
+                          #'guix-history-add)
+                        (,history-fun)))
+             (pop-to-buffer buf
+                            '((display-buffer-reuse-window
+                               display-buffer-same-window)))))
+         (guix-result-message entries ',entry-type
+                              search-type search-vals))
+
+       (defun ,show-fun (entries)
+         ,(concat "Display " entry-type-str " ENTRIES in the current " buf-str ".")
+         (let ((inhibit-read-only t))
+           (erase-buffer)
+           (,mode)
+           (,(intern (concat "guix-" buf-type-str "-insert-entries"))
+            entries ',entry-type)
+           (goto-char (point-min))))
+
+       (defun ,get-show-fun (search-type &rest search-vals)
+         ,(concat "Search for " entry-str " and show results in the " buf-str ".\n"
+                  "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n"
+                  "SEARCH-VALS.")
+         (let ((entries (guix-get-entries ',entry-type search-type
+                                          search-vals (,params-fun))))
+           (,set-fun entries search-type search-vals))))))
+
+(put 'guix-define-buffer-type 'lisp-indent-function 'defun)
+
+
+;;; Messages
+
+(defvar guix-messages
+  '((package
+     (id
+      (0 "Packages not found.")
+      (1 "")
+      (many "%d packages." count))
+     (name
+      (0 "The package '%s' not found." val)
+      (1 "A single package with name '%s'." val)
+      (many "%d packages with '%s' name." count val))
+     (regexp
+      (0 "No packages matching '%s'." val)
+      (1 "A single package matching '%s'." val)
+      (many "%d packages matching '%s'." count val))
+     (all-available
+      (0 "No packages are available for some reason.")
+      (1 "A single available package (that's strange).")
+      (many "%d available packages." count))
+     (newest-available
+      (0 "No packages are available for some reason.")
+      (1 "A single newest available package (that's strange).")
+      (many "%d newest available packages." count))
+     (installed
+      (0 "No installed packages.")
+      (1 "A single installed package.")
+      (many "%d installed packages." count))
+     (obsolete
+      (0 "No obsolete packages.")
+      (1 "A single obsolete package.")
+      (many "%d obsolete packages." count))
+     (generation
+      (0 "No packages installed in generation %d." val)
+      (1 "A single package installed in generation %d." val)
+      (many "%d packages installed in generation %d." count val)))
+    (generation
+     (id
+      (0 "Generations not found.")
+      (1 "")
+      (many "%d generations." count))
+     (last
+      (0 "No available generations.")
+      (1 "The last generation.")
+      (many "%d last generations." count))
+     (all
+      (0 "No available generations.")
+      (1 "A single available generation.")
+      (many "%d available generations." count)))))
+
+(defun guix-result-message (entries entry-type search-type search-vals)
+  "Display an appropriate message after displaying ENTRIES."
+  (let* ((val (car search-vals))
+         (count (length entries))
+         (count-key (if (> count 1) 'many count))
+         (msg-spec (guix-get-key-val guix-messages
+                                     entry-type search-type count-key))
+         (format (car msg-spec))
+         (args (cdr msg-spec)))
+    (mapc (lambda (subst)
+            (setq args (cl-substitute (car subst) (cdr subst) args)))
+          (list (cons count 'count)
+                (cons val 'val)))
+    (apply #'message format args)))
+
+
+;;; Getting info about packages and generations
+
+(defun guix-get-entries (entry-type search-type search-vals &optional params)
+  "Search for entries of ENTRY-TYPE.
+
+Call an appropriate scheme function and return a list of the
+form of `guix-entries'.
+
+ENTRY-TYPE should be one of the following symbols: `package' or
+`generation'.
+
+SEARCH-TYPE may be one of the following symbols:
+
+- If ENTRY-TYPE is `package': `id', `name', `regexp',
+  `all-available', `newest-available', `installed', `obsolete',
+  `generation'.
+
+- If ENTRY-TYPE is `generation': `id', `last', `all'.
+
+PARAMS is a list of parameters for receiving.  If nil, get
+information with all available parameters."
+  (guix-eval-read (guix-make-guile-expression
+                   'get-entries
+                   guix-current-profile params
+                   entry-type search-type search-vals)))
+
+
+;;; Actions on packages and generations
+
+(defcustom guix-operation-confirm t
+  "If nil, do not prompt to confirm an operation."
+  :type 'boolean
+  :group 'guix)
+
+(defcustom guix-use-substitutes t
+  "If non-nil, use substitutes for the Guix packages."
+  :type 'boolean
+  :group 'guix)
+
+(defvar guix-dry-run nil
+  "If non-nil, do not perform the real actions, just simulate.")
+
+(defvar guix-temp-buffer-name " *Guix temp*"
+  "Name of a buffer used for displaying info before executing operation.")
+
+(defun guix-process-package-actions (&rest actions)
+  "Process package ACTIONS.
+Each action is a list of the form:
+
+  (ACTION-TYPE PACKAGE-SPEC ...)
+
+ACTION-TYPE is one of the following symbols: `install',
+`upgrade', `remove'/`delete'.
+PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)."
+  (let (install upgrade remove)
+    (mapc (lambda (action)
+            (let ((action-type (car action))
+                  (specs (cdr action)))
+              (cl-case action-type
+                (install (setq install (append install specs)))
+                (upgrade (setq upgrade (append upgrade specs)))
+                ((remove delete) (setq remove (append remove specs))))))
+          actions)
+    (when (guix-continue-package-operation-p
+           :install install :upgrade upgrade :remove remove)
+      (guix-eval-in-repl
+       (guix-make-guile-expression
+        'process-package-actions guix-current-profile
+        :install install :upgrade upgrade :remove remove
+        :use-substitutes? (or guix-use-substitutes 'f)
+        :dry-run? (or guix-dry-run 'f))))))
+
+(cl-defun guix-continue-package-operation-p (&key install upgrade remove)
+  "Return non-nil if a package operation should be continued.
+Ask a user if needed (see `guix-operation-confirm').
+INSTALL, UPGRADE, REMOVE are 'package action specifications'.
+See `guix-process-package-actions' for details."
+  (or (null guix-operation-confirm)
+      (let* ((entries (guix-get-entries
+                       'package 'id
+                       (list (append (mapcar #'car install)
+                                     (mapcar #'car upgrade)
+                                     (mapcar #'car remove)))
+                       '(id name version location)))
+             (install-strings (guix-get-package-strings install entries))
+             (upgrade-strings (guix-get-package-strings upgrade entries))
+             (remove-strings  (guix-get-package-strings remove entries)))
+        (if (or install-strings upgrade-strings remove-strings)
+            (let ((buf (get-buffer-create guix-temp-buffer-name)))
+              (with-current-buffer buf
+                (setq-local cursor-type nil)
+                (setq buffer-read-only nil)
+                (erase-buffer)
+                (guix-insert-package-strings install-strings "install")
+                (guix-insert-package-strings upgrade-strings "upgrade")
+                (guix-insert-package-strings remove-strings "remove")
+                (let ((win (temp-buffer-window-show
+                            buf
+                            '((display-buffer-reuse-window
+                               display-buffer-at-bottom)
+                              (window-height . fit-window-to-buffer)))))
+                  (prog1 (y-or-n-p "Continue operation? ")
+                    (quit-window nil win)))))
+          (message "Nothing to be done.  If the REPL was restarted, information is not up-to-date.")
+          nil))))
+
+(defun guix-get-package-strings (specs entries)
+  "Return short package descriptions for performing package actions.
+See `guix-process-package-actions' for the meaning of SPECS.
+ENTRIES is a list of package entries to get info about packages."
+  (delq nil
+        (mapcar
+         (lambda (spec)
+           (let* ((id (car spec))
+                  (outputs (cdr spec))
+                  (entry (guix-get-entry-by-id id entries)))
+             (when entry
+               (let ((location (guix-get-key-val entry 'location)))
+                 (concat (guix-get-full-name entry)
+                         (when outputs
+                           (concat ":"
+                                   (mapconcat #'identity outputs ",")))
+                         (when location
+                           (concat "\t(" location ")")))))))
+         specs)))
+
+(defun guix-insert-package-strings (strings action)
+  "Insert information STRINGS at point for performing package ACTION."
+  (when strings
+    (insert "Package(s) to " (guix-get-string action 'bold) ":\n")
+    (mapc (lambda (str)
+            (insert "  " str "\n"))
+          strings)
+    (insert "\n")))
+
+(provide 'guix-base)
+
+;;; guix-base.el ends here

emacs/guix-helper.scm.in

@@ -0,0 +1,64 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is an auxiliary file for the Emacs UI.  It is used to add Guix
+;; directories to path variables and to load the main code.
+
+;;; Code:
+
+(use-modules (ice-9 regex)
+             (srfi srfi-26))
+
+(define %guix-dir)
+
+;; The code is taken from ‘guix’ executable script
+(define (set-paths!)
+  (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+
+  (define config-lookup
+    (let ((config '(("prefix"         . "@prefix@")
+                    ("guilemoduledir" . "@guilemoduledir@")))
+          (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}")))
+      (define (expand-var-ref match)
+        (lookup (match:substring match 1)))
+      (define (expand str)
+        (regexp-substitute/global #f var-ref-regexp str
+                                  'pre expand-var-ref 'post))
+      (define (lookup name)
+        (expand (assoc-ref config name)))
+      lookup))
+
+  (let ((module-dir (config-lookup "guilemoduledir"))
+        (updates-dir (and=> (or (getenv "XDG_CONFIG_HOME")
+                                (and=> (getenv "HOME")
+                                       (cut string-append <> "/.config")))
+                            (cut string-append <> "/guix/latest"))))
+    (push! module-dir %load-compiled-path)
+    (if (and updates-dir (file-exists? updates-dir))
+        (begin
+          (set! %guix-dir updates-dir)
+          (push! updates-dir %load-path)
+          (push! updates-dir %load-compiled-path))
+        (set! %guix-dir module-dir))))
+
+(set-paths!)
+
+(load-from-path "guix-main")
+

emacs/guix-history.el

@@ -0,0 +1,92 @@
+;;; guix-history.el --- History of buffer information
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides support for history of buffers similar to the
+;; history of a `help-mode' buffer.
+
+;;; Code:
+
+(require 'cl-macs)
+
+(defvar-local guix-history-stack-item nil
+  "Current item of the history.
+A list of the form (FUNCTION [ARGS ...]).
+The item is used by calling (apply FUNCTION ARGS).")
+(put 'guix-history-stack-item 'permanent-local t)
+
+(defvar-local guix-history-back-stack nil
+  "Stack (list) of visited items.
+Each element of the list has a form of `guix-history-stack-item'.")
+(put 'guix-history-back-stack 'permanent-local t)
+
+(defvar-local guix-history-forward-stack nil
+  "Stack (list) of items visited with `guix-history-back'.
+Each element of the list has a form of `guix-history-stack-item'.")
+(put 'guix-history-forward-stack 'permanent-local t)
+
+(defvar guix-history-size 0
+  "Maximum number of items saved in history.
+If 0, the history is disabled.")
+
+(defun guix-history-add (item)
+  "Add ITEM to history."
+  (and guix-history-stack-item
+       (push guix-history-stack-item guix-history-back-stack))
+  (setq guix-history-forward-stack nil
+        guix-history-stack-item item)
+  (when (>= (length guix-history-back-stack)
+            guix-history-size)
+    (setq guix-history-back-stack
+          (cl-loop for elt in guix-history-back-stack
+                   for i from 1 to guix-history-size
+                   collect elt))))
+
+(defun guix-history-replace (item)
+  "Replace current item in history with ITEM."
+  (setq guix-history-stack-item item))
+
+(defun guix-history-goto (item)
+  "Go to the ITEM of history.
+ITEM should have the form of `guix-history-stack-item'."
+  (or (listp item)
+      (error "Wrong value of history element"))
+  (setq guix-history-stack-item item)
+  (apply (car item) (cdr item)))
+
+(defun guix-history-back ()
+  "Go back to the previous element of history in the current buffer."
+  (interactive)
+  (or guix-history-back-stack
+      (user-error "No previous element in history"))
+  (push guix-history-stack-item guix-history-forward-stack)
+  (guix-history-goto (pop guix-history-back-stack)))
+
+(defun guix-history-forward ()
+  "Go forward to the next element of history in the current buffer."
+  (interactive)
+  (or guix-history-forward-stack
+      (user-error "No next element in history"))
+  (push guix-history-stack-item guix-history-back-stack)
+  (guix-history-goto (pop guix-history-forward-stack)))
+
+(provide 'guix-history)
+
+;;; guix-history.el ends here

emacs/guix-info.el

@@ -0,0 +1,556 @@
+;;; guix-info.el --- Info buffers for displaying entries
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides a help-like buffer for displaying information
+;; about Guix packages and generations.
+
+;;; Code:
+
+(require 'guix-history)
+(require 'guix-base)
+(require 'guix-utils)
+
+(defgroup guix-info nil
+  "General settings for info buffers."
+  :prefix "guix-info-"
+  :group 'guix)
+
+(defface guix-info-param-title
+  '((t :inherit font-lock-type-face))
+  "Face used for titles of parameters."
+  :group 'guix-info)
+
+(defface guix-info-file-path
+  '((t :inherit link))
+  "Face used for file paths."
+  :group 'guix-info)
+
+(defface guix-info-url
+  '((t :inherit link))
+  "Face used for URLs."
+  :group 'guix-info)
+
+(defface guix-info-time
+  '((t :inherit font-lock-constant-face))
+  "Face used for timestamps."
+  :group 'guix-info)
+
+(defface guix-info-action-button
+  '((((type x w32 ns) (class color))
+     :box (:line-width 2 :style released-button)
+     :background "lightgrey" :foreground "black")
+    (t :inherit button))
+  "Face used for action buttons."
+  :group 'guix-info)
+
+(defface guix-info-action-button-mouse
+  '((((type x w32 ns) (class color))
+     :box (:line-width 2 :style released-button)
+     :background "grey90" :foreground "black")
+    (t :inherit highlight))
+  "Mouse face used for action buttons."
+  :group 'guix-info)
+
+(defcustom guix-info-ignore-empty-vals nil
+  "If non-nil, do not display parameters with nil values."
+  :type 'boolean
+  :group 'guix-info)
+
+(defvar guix-info-param-title-format "%-18s: "
+  "String used to format a title of a parameter.
+It should be a '%s'-sequence.  After inserting a title formatted
+with this string, a value of the parameter is inserted.
+This string is used by `guix-info-insert-title-default'.")
+
+(defvar guix-info-multiline-prefix (make-string 20 ?\s)
+  "String used to format multi-line parameter values.
+If a value occupies more than one line, this string is inserted
+in the beginning of each line after the first one.
+This string is used by `guix-info-insert-val-default'.")
+
+(defvar guix-info-indent 2
+  "Number of spaces used to indent various parts of inserted text.")
+
+(defvar guix-info-fill-column 60
+  "Column used for filling (word wrapping) parameters with long lines.
+If a value is not multi-line and it occupies more than this
+number of characters, it will be split into several lines.")
+
+(defvar guix-info-delimiter "\n\f\n"
+  "String used to separate entries.")
+
+(defvar guix-info-insert-methods
+  '((package
+     (name              guix-package-info-name)
+     (version           guix-package-info-version)
+     (license           guix-package-info-license)
+     (synopsis          guix-package-info-synopsis)
+     (description       guix-package-info-insert-description
+                        guix-info-insert-title-simple)
+     (outputs           guix-package-info-insert-outputs
+                        guix-info-insert-title-simple)
+     (home-url          guix-info-insert-url)
+     (inputs            guix-package-info-insert-inputs)
+     (native-inputs     guix-package-info-insert-native-inputs)
+     (propagated-inputs guix-package-info-insert-propagated-inputs)
+     (location          guix-package-info-insert-location))
+    (installed
+     (path              guix-package-info-insert-output-path
+                        guix-info-insert-title-simple)
+     (dependencies      guix-package-info-insert-output-dependencies
+                        guix-info-insert-title-simple))
+    (generation
+     (number            guix-generation-info-insert-number)
+     (path              guix-info-insert-file-path)
+     (time              guix-info-insert-time)))
+  "Methods for inserting parameter values.
+Each element of the list should have a form:
+
+  (ENTRY-TYPE . ((PARAM INSERT-VALUE [INSERT-TITLE]) ...))
+
+INSERT-VALUE may be either nil, a face name or a function.  If it
+is nil or a face, `guix-info-insert-val-default' function is
+called with parameter value and INSERT-VALUE as arguments.  If it
+is a function, this function is called with parameter value and
+entry info (alist of parameters and their values) as arguments.
+
+INSERT-TITLE may be either nil, a face name or a function.  If it
+is nil or a face, `guix-info-insert-title-default' function is
+called with parameter title and INSERT-TITLE as arguments.  If it
+is a function, this function is called with parameter title as
+argument.")
+
+(defvar guix-info-displayed-params
+  '((package name version synopsis outputs location home-url
+             license inputs native-inputs propagated-inputs description)
+    (installed path dependencies)
+    (generation number prev-number time path))
+  "List of displayed entry parameters.
+Each element of the list should have a form:
+
+  (ENTRY-TYPE . (PARAM ...))
+
+The order of displayed parameters is the same as in this list.")
+
+(defun guix-info-get-insert-methods (entry-type param)
+  "Return list of insert methods for parameter PARAM of ENTRY-TYPE.
+See `guix-info-insert-methods' for details."
+  (guix-get-key-val guix-info-insert-methods
+                    entry-type param))
+
+(defun guix-info-get-displayed-params (entry-type)
+  "Return parameters of ENTRY-TYPE that should be displayed."
+  (guix-get-key-val guix-info-displayed-params
+                    entry-type))
+
+(defun guix-info-get-indent (&optional level)
+  "Return `guix-info-indent' \"multiplied\" by LEVEL spaces.
+LEVEL is 1 by default."
+  (make-string (* guix-info-indent (or level 1)) ?\s))
+
+(defun guix-info-insert-indent (&optional level)
+  "Insert `guix-info-indent' spaces LEVEL times (1 by default)."
+  (insert (guix-info-get-indent level)))
+
+(defun guix-info-insert-entries (entries entry-type)
+  "Display ENTRIES of ENTRY-TYPE in the current info buffer.
+ENTRIES should have a form of `guix-entries'."
+  (guix-mapinsert (lambda (entry)
+                    (guix-info-insert-entry entry entry-type))
+                  entries
+                  guix-info-delimiter))
+
+(defun guix-info-insert-entry (entry entry-type &optional indent-level)
+  "Insert ENTRY of ENTRY-TYPE into the current info buffer.
+If INDENT-LEVEL is non-nil, indent displayed information by this
+number of `guix-info-indent' spaces."
+  (let ((region-beg (point)))
+    (mapc (lambda (param)
+            (guix-info-insert-param param entry entry-type))
+          (guix-info-get-displayed-params entry-type))
+    (when indent-level
+      (indent-rigidly region-beg (point)
+                      (* indent-level guix-info-indent)))))
+
+(defun guix-info-insert-param (param entry entry-type)
+  "Insert title and value of a PARAM at point.
+ENTRY is alist with parameters and their values.
+ENTRY-TYPE is a type of ENTRY."
+  (let ((val (guix-get-key-val entry param)))
+    (unless (and guix-info-ignore-empty-vals (null val))
+      (let* ((title          (guix-get-param-title entry-type param))
+             (insert-methods (guix-info-get-insert-methods entry-type param))
+             (val-method     (car insert-methods))
+             (title-method   (cadr insert-methods)))
+        (guix-info-method-funcall title title-method
+                                  #'guix-info-insert-title-default)
+        (guix-info-method-funcall val val-method
+                                  #'guix-info-insert-val-default
+                                  entry)
+        (insert "\n")))))
+
+(defun guix-info-method-funcall (val method default-fun &rest args)
+  "Call METHOD or DEFAULT-FUN.
+
+If METHOD is a function and VAL is non-nil, call this
+function by applying it to VAL and ARGS.
+
+If METHOD is a face, propertize inserted VAL with this face."
+  (cond ((or (null method)
+             (facep method))
+         (funcall default-fun val method))
+        ((functionp method)
+         (apply method val args))
+        (t (error "Unknown method '%S'" method))))
+
+(defun guix-info-insert-title-default (title &optional face format)
+  "Insert TITLE formatted with `guix-info-param-title-format' at point."
+  (guix-format-insert title
+                      (or face 'guix-info-param-title)
+                      (or format guix-info-param-title-format)))
+
+(defun guix-info-insert-title-simple (title &optional face)
+  "Insert TITLE at point."
+  (guix-info-insert-title-default title face "%s:"))
+
+(defun guix-info-insert-val-default (val &optional face)
+  "Format and insert parameter value VAL at point.
+
+This function is intended to be called after
+`guix-info-insert-title-default'.
+
+If VAL is a one-line string longer than `guix-info-fill-column',
+split it into several short lines.  See also
+`guix-info-multiline-prefix'.
+
+If FACE is non-nil, propertize inserted line(s) with this FACE."
+  (guix-split-insert val face
+                     guix-info-fill-column
+                     (concat "\n" guix-info-multiline-prefix)))
+
+(defun guix-info-insert-val-simple (val &optional face-or-fun)
+  "Format and insert parameter value VAL at point.
+
+This function is intended to be called after
+`guix-info-insert-title-simple'.
+
+If VAL is a one-line string longer than `guix-info-fill-column',
+split it into several short lines and indent each line with
+`guix-info-indent' spaces.
+
+If FACE-OR-FUN is a face, propertize inserted line(s) with this FACE.
+
+If FACE-OR-FUN is a function, call it with VAL as argument.  If
+VAL is a list, call the function on each element of this list."
+  (if (null val)
+      (progn (guix-info-insert-indent)
+             (guix-format-insert nil))
+    (let ((prefix (concat "\n" (guix-info-get-indent))))
+      (insert prefix)
+      (if (functionp face-or-fun)
+          (guix-mapinsert face-or-fun
+                          (if (listp val) val (list val))
+                          prefix)
+        (guix-split-insert val face-or-fun
+                           guix-info-fill-column prefix)))))
+
+(defun guix-info-insert-action-button (label action &optional message
+                                             &rest properties)
+  "Make action button with LABEL and insert it at point.
+For the meaning of ACTION, MESSAGE and PROPERTIES, see
+`guix-insert-button'."
+  (apply #'guix-insert-button
+         label 'guix-info-action-button action message
+         'mouse-face 'guix-info-action-button-mouse
+         properties))
+
+(defun guix-info-insert-file-path (path &optional _)
+  "Make button from file PATH and insert it at point."
+  (guix-insert-button
+   path 'guix-info-file-path
+   (lambda (btn) (find-file (button-label btn)))
+   "Find file"))
+
+(defun guix-info-insert-url (url &optional _)
+  "Make button from URL and insert it at point."
+  (guix-insert-button
+   url 'guix-info-url
+   (lambda (btn) (browse-url (button-label btn)))
+   "Browse URL"))
+
+(defun guix-info-insert-time (seconds &optional _)
+  "Insert formatted time string using SECONDS at point."
+  (guix-info-insert-val-default (guix-get-time-string seconds)
+                                'guix-info-time))
+
+
+(defvar guix-info-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent
+     map (make-composed-keymap button-buffer-map
+                               special-mode-map))
+    map)
+  "Parent keymap for info buffers.")
+
+(define-derived-mode guix-info-mode special-mode "Guix-Info"
+  "Parent mode for displaying information in info buffers.")
+
+
+;;; Displaying packages
+
+(guix-define-buffer-type info package
+  :required (id installed non-unique))
+
+(defface guix-package-info-name
+  '((t :inherit font-lock-keyword-face))
+  "Face used for a name of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-version
+  '((t :inherit font-lock-builtin-face))
+  "Face used for a version of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-synopsis
+  '((t :inherit font-lock-doc-face))
+  "Face used for a synopsis of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-description
+  '((t))
+  "Face used for a description of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-license
+  '((t :inherit font-lock-string-face))
+  "Face used for a license of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-location
+  '((t :inherit link))
+  "Face used for a location of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-installed-outputs
+  '((default :weight bold)
+    (((class color) (min-colors 88) (background light))
+     :foreground "ForestGreen")
+    (((class color) (min-colors 88) (background dark))
+     :foreground "PaleGreen")
+    (((class color) (min-colors 8))
+     :foreground "green")
+    (t :underline t))
+  "Face used for installed outputs of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-uninstalled-outputs
+  '((t :weight bold))
+  "Face used for uninstalled outputs of a package."
+  :group 'guix-package-info)
+
+(defface guix-package-info-obsolete
+  '((t :inherit error))
+  "Face used if a package is obsolete."
+  :group 'guix-package-info)
+
+(defun guix-package-info-insert-description (desc &optional _)
+  "Insert description DESC at point."
+  (guix-info-insert-val-simple desc 'guix-package-info-description))
+
+(defun guix-package-info-insert-location (location &optional _)
+  "Make button from file LOCATION and insert it at point."
+  (guix-insert-button
+   location 'guix-package-info-location
+   (lambda (btn) (guix-find-location (button-label btn)))
+   "Find location of this package"))
+
+(defmacro guix-package-info-define-insert-inputs (&optional type)
+  "Define a face and a function for inserting package inputs.
+TYPE is a type of inputs.
+Function name is `guix-package-info-insert-TYPE-inputs'.
+Face name is `guix-package-info-TYPE-inputs'."
+  (let* ((type-str (symbol-name type))
+         (type-name (and type (concat type-str "-")))
+         (type-desc (and type (concat type-str " ")))
+         (face (intern (concat "guix-package-info-" type-name "inputs")))
+         (fun  (intern (concat "guix-package-info-insert-" type-name "inputs"))))
+    `(progn
+       (defface ,face
+         '((t :inherit button))
+         ,(concat "Face used for " type-desc "inputs of a package.")
+         :group 'guix-package-info)
+
+       (defun ,fun (inputs &optional _)
+         ,(concat "Make buttons from " type-desc "INPUTS and insert them at point.")
+         (guix-package-info-insert-full-names inputs ',face)))))
+
+(guix-package-info-define-insert-inputs)
+(guix-package-info-define-insert-inputs native)
+(guix-package-info-define-insert-inputs propagated)
+
+(defun guix-package-info-insert-full-names (names face)
+  "Make buttons from package NAMES and insert them at point.
+NAMES is a list of strings.
+Propertize buttons with FACE."
+  (if names
+      (guix-info-insert-val-default
+       (with-temp-buffer
+         (guix-mapinsert (lambda (name)
+                           (guix-package-info-insert-full-name
+                            name face))
+                         names
+                         guix-list-separator)
+         (buffer-substring (point-min) (point-max))))
+    (guix-format-insert nil)))
+
+(defun guix-package-info-insert-full-name (name face)
+  "Make button and insert package NAME at point.
+Propertize package button with FACE."
+  (guix-insert-button
+   name face
+   (lambda (btn)
+     (guix-package-info-get-show 'name (button-label btn)))
+   "Describe this package"))
+
+
+;;; Inserting outputs and installed parameters
+
+(defvar guix-package-info-output-format "%-10s"
+  "String used to format output names of the packages.
+It should be a '%s'-sequence.  After inserting an output name
+formatted with this string, an action button is inserted.")
+
+(defvar guix-package-info-obsolete-string "(This package is obsolete)"
+  "String used if a package is obsolete.")
+
+(defun guix-package-info-insert-outputs (outputs entry)
+  "Insert OUTPUTS from package ENTRY at point."
+  (and (guix-get-key-val entry 'obsolete)
+       (guix-package-info-insert-obsolete-text))
+  (and (guix-get-key-val entry 'non-unique)
+       (guix-get-key-val entry 'installed)
+       (guix-package-info-insert-non-unique-text
+        (guix-get-full-name entry)))
+  (insert "\n")
+  (mapc (lambda (output)
+          (guix-package-info-insert-output output entry))
+        outputs))
+
+(defun guix-package-info-insert-obsolete-text ()
+  "Insert a message about obsolete package at point."
+  (guix-info-insert-indent)
+  (guix-format-insert guix-package-info-obsolete-string
+                      'guix-package-info-obsolete))
+
+(defun guix-package-info-insert-non-unique-text (full-name)
+  "Insert a message about non-unique package with FULL-NAME at point."
+  (insert "\n")
+  (guix-info-insert-indent)
+  (insert "Installed outputs are displayed for a non-unique ")
+  (guix-package-info-insert-full-name full-name
+                                      'guix-package-info-inputs)
+  (insert " package."))
+
+(defun guix-package-info-insert-output (output entry)
+  "Insert OUTPUT at point.
+Make some fancy text with buttons and additional stuff if the
+current OUTPUT is installed (if there is such output in
+`installed' parameter of a package ENTRY)."
+  (let* ((installed (guix-get-key-val entry 'installed))
+         (obsolete  (guix-get-key-val entry 'obsolete))
+         (installed-entry (cl-find-if
+                           (lambda (entry)
+                             (string= (guix-get-key-val entry 'output)
+                                      output))
+                           installed))
+         (action-type (if installed-entry 'delete 'install)))
+    (guix-info-insert-indent)
+    (guix-format-insert output
+                        (if installed-entry
+                            'guix-package-info-installed-outputs
+                          'guix-package-info-uninstalled-outputs)
+                        guix-package-info-output-format)
+    (guix-package-info-insert-action-button action-type entry output)
+    (when obsolete
+      (guix-info-insert-indent)
+      (guix-package-info-insert-action-button 'upgrade entry output))
+    (insert "\n")
+    (when installed-entry
+      (guix-info-insert-entry installed-entry 'installed 2))))
+
+(defun guix-package-info-insert-action-button (type entry output)
+  "Insert button to process an action on a package OUTPUT at point.
+TYPE is one of the following symbols: `install', `delete', `upgrade'.
+ENTRY is an alist with package info."
+  (let ((type-str (capitalize (symbol-name type)))
+        (full-name (guix-get-full-name entry output)))
+    (guix-info-insert-action-button
+     type-str
+     (lambda (btn)
+       (guix-process-package-actions
+        (list (button-get btn 'action-type)
+              (list (button-get btn 'id)
+                    (button-get btn 'output)))))
+     (concat type-str " '" full-name "'")
+     'action-type type
+     'id (guix-get-key-val entry 'id)
+     'output output)))
+
+(defun guix-package-info-insert-output-path (path &optional _)
+  "Insert PATH of the installed output."
+  (guix-info-insert-val-simple path #'guix-info-insert-file-path))
+
+(defun guix-package-info-insert-output-dependencies (deps &optional _)
+  "Insert dependencies DEPS of the installed output."
+  (guix-info-insert-val-simple deps #'guix-info-insert-file-path))
+
+
+;;; Displaying generations
+
+(guix-define-buffer-type info generation)
+
+(defface guix-generation-info-number
+  '((t :inherit font-lock-keyword-face))
+  "Face used for a number of a generation."
+  :group 'guix-generation-info)
+
+(declare-function guix-package-list-get-show "guix-list" t t)
+
+(defun guix-generation-info-insert-number (number &optional _)
+  "Insert generation NUMBER and action buttons."
+  (guix-info-insert-val-default number 'guix-generation-info-number)
+  (guix-info-insert-indent)
+  (guix-info-insert-action-button
+   "Packages"
+   (lambda (btn)
+     (guix-package-list-get-show 'generation
+                                 (button-get btn 'number)))
+   "Show installed packages for this generation"
+   'number number)
+  (guix-info-insert-indent)
+  (guix-info-insert-action-button
+   "Delete"
+   (lambda (btn) (error "Sorry, not implemented yet"))
+   "Delete this generation"))
+
+(provide 'guix-info)
+
+;;; guix-info.el ends here

emacs/guix-init.el.in

@@ -0,0 +1,14 @@
+(require 'guix-autoloads)
+
+(defvar guix-load-path
+  (replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@")
+  "Directory with scheme files for \"guix.el\" package.")
+
+(defvar guix-default-profile
+  (concat (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")
+          "/profiles/per-user/"
+          (getenv "USER")
+          "/guix-profile")
+  "Default Guix profile.")
+
+(provide 'guix-init)

emacs/guix-list.el

@@ -0,0 +1,594 @@
+;;; guix-list.el --- List buffers for displaying entries   -*- lexical-binding: t -*-
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides a list-like buffer for displaying information
+;; about Guix packages and generations.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'tabulated-list)
+(require 'guix-info)
+(require 'guix-history)
+(require 'guix-base)
+(require 'guix-utils)
+
+(defgroup guix-list nil
+  "General settings for list buffers."
+  :prefix "guix-list-"
+  :group 'guix)
+
+(defface guix-list-file-path
+  '((t :inherit guix-info-file-path))
+  "Face used for file paths."
+  :group 'guix-list)
+
+(defcustom guix-list-describe-warning-count 10
+  "The maximum number of entries for describing without a warning.
+If a user wants to describe more than this number of marked
+entries, he will be prompted for confirmation."
+  :type 'integer
+  :group 'guix-list)
+
+(defvar guix-list-column-format
+  `((package
+     (name 20 t)
+     (version 10 nil)
+     (outputs 13 t)
+     (installed 13 t)
+     (synopsis 30 nil))
+    (generation
+     (number 5
+             ,(lambda (a b) (guix-list-sort-numerically 0 a b))
+             :right-align t)
+     (time 20 t)
+     (path 30 t)))
+  "Columns displayed in list buffers.
+Each element of the list has a form:
+
+  (ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...))
+
+PARAM is the name of an entry parameter of ENTRY-TYPE.  For the
+meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.")
+
+(defvar guix-list-column-titles
+  '((generation
+     (number . "N.")))
+  "Column titles for list buffers.
+Has the same structure as `guix-param-titles', but titles from
+this list have a priority.")
+
+(defvar guix-list-column-value-methods
+  '((package
+     (name        . guix-package-list-get-name)
+     (synopsis    . guix-list-get-one-line)
+     (description . guix-list-get-one-line)
+     (installed   . guix-package-list-get-installed-outputs))
+    (generation
+     (time . guix-list-get-time)
+     (path . guix-list-get-file-path)))
+  "Methods for inserting parameter values in columns.
+Each element of the list has a form:
+
+  (ENTRY-TYPE . ((PARAM . FUN) ...))
+
+PARAM is the name of an entry parameter of ENTRY-TYPE.
+
+FUN is a function returning a value that will be inserted.  The
+function is called with 2 arguments: the first one is the value
+of the parameter; the second argument is an entry info (alist of
+parameters and their values).")
+
+(defun guix-list-get-param-title (entry-type param)
+  "Return title of an ENTRY-TYPE entry parameter PARAM."
+  (or (guix-get-key-val guix-list-column-titles
+                        entry-type param)
+      (guix-get-param-title entry-type param)))
+
+(defun guix-list-get-column-format (entry-type)
+  "Return column format for ENTRY-TYPE."
+  (guix-get-key-val guix-list-column-format entry-type))
+
+(defun guix-list-get-displayed-params (entry-type)
+  "Return list of parameters of ENTRY-TYPE that should be displayed."
+  (mapcar #'car
+          (guix-list-get-column-format entry-type)))
+
+(defun guix-list-get-sort-key (entry-type param &optional invert)
+  "Return suitable sort key for `tabulated-list-sort-key'.
+Define column title by ENTRY-TYPE and PARAM.  If INVERT is
+non-nil, invert the sort."
+  (when (memq param (guix-list-get-displayed-params entry-type))
+    (cons (guix-list-get-param-title entry-type param) invert)))
+
+(defun guix-list-sort-numerically (column a b)
+  "Compare COLUMN of tabulated entries A and B numerically.
+It is a sort predicate for `tabulated-list-format'.
+Return non-nil, if B is bigger than A."
+  (cl-flet ((num (entry)
+              (string-to-number (aref (cadr entry) column))))
+    (> (num b) (num a))))
+
+(defun guix-list-make-tabulated-vector (entry-type fun)
+  "Call FUN on each column specification for ENTRY-TYPE.
+
+FUN is called with 2 argument: parameter name and column
+specification (see `guix-list-column-format').
+
+Return a vector made of values of FUN calls."
+  (apply #'vector
+         (mapcar (lambda (col-spec)
+                   (funcall fun (car col-spec) (cdr col-spec)))
+                 (guix-list-get-column-format entry-type))))
+
+(defun guix-list-get-list-format (entry-type)
+  "Return ENTRY-TYPE list specification for `tabulated-list-format'."
+  (guix-list-make-tabulated-vector
+   entry-type
+   (lambda (param spec)
+     (cons (guix-list-get-param-title entry-type param)
+           spec))))
+
+(defun guix-list-insert-entries (entries entry-type)
+  "Display ENTRIES of ENTRY-TYPE in the current list buffer.
+ENTRIES should have a form of `guix-entries'."
+  (setq tabulated-list-entries
+        (guix-list-get-tabulated-entries entries entry-type))
+  (tabulated-list-print))
+
+(defun guix-list-get-tabulated-entries (entries entry-type)
+  "Return list of values of ENTRY-TYPE for `tabulated-list-entries'.
+Values are taken from ENTRIES which should have the form of
+`guix-entries'."
+  (mapcar (lambda (entry)
+            (list (guix-get-key-val entry 'id)
+                  (guix-list-get-tabulated-entry entry entry-type)))
+          entries))
+
+(defun guix-list-get-tabulated-entry (entry entry-type)
+  "Return array of values for `tabulated-list-entries'.
+Parameters are taken from ENTRY of ENTRY-TYPE."
+  (guix-list-make-tabulated-vector
+   entry-type
+   (lambda (param _)
+     (let ((val (guix-get-key-val entry param))
+           (fun (guix-get-key-val guix-list-column-value-methods
+                                  entry-type param)))
+       (if (and val fun)
+           (funcall fun val entry)
+         (guix-get-string val))))))
+
+(defun guix-list-get-one-line (str &optional _)
+  "Return one-line string from a multi-line STR."
+  (guix-get-one-line str))
+
+(defun guix-list-get-time (seconds &optional _)
+  "Return formatted time string from SECONDS."
+  (guix-get-time-string seconds))
+
+(defun guix-list-get-file-path (path &optional _)
+  "Return PATH button specification for `tabulated-list-entries'."
+  (list path
+        'face 'guix-list-file-path
+        'action (lambda (btn) (find-file (button-label btn)))
+        'follow-link t
+        'help-echo "Find file"))
+
+(defun guix-list-current-id ()
+  "Return ID of the current entry."
+  (or (tabulated-list-get-id)
+      (user-error "No entry here")))
+
+(defun guix-list-current-entry ()
+  "Return alist of the current entry info."
+  (guix-get-entry-by-id (guix-list-current-id) guix-entries))
+
+(defun guix-list-for-each-line (fun &rest args)
+  "Call FUN with ARGS for each entry line."
+  (or (derived-mode-p 'guix-list-mode)
+      (error "The current buffer is not in Guix List mode"))
+  (save-excursion
+    (goto-char (point-min))
+    (while (not (eobp))
+      (apply fun args)
+      (forward-line))))
+
+(defun guix-list-fold-lines (fun init)
+  "Fold over entry lines in the current list buffer.
+Call FUN with RESULT as argument for each line, using INIT as
+the initial value of RESULT.  Return the final result."
+  (let ((res init))
+    (guix-list-for-each-line
+     (lambda () (setq res (funcall fun res))))
+    res))
+
+
+;;; Marking and sorting
+
+(defvar-local guix-list-marked nil
+  "List of the marked entries.
+Each element of the list has a form:
+
+  (ID MARK-NAME . ARGS)
+
+ID is an entry ID.
+MARK-NAME is a symbol from `guix-list-mark-alist'.
+ARGS is a list of additional values.")
+
+(defvar guix-list-mark-alist
+  '((empty   . ?\s)
+    (general . ?*))
+  "Alist of available mark names and mark characters.")
+
+(defsubst guix-list-get-mark (name)
+  "Return mark character by its NAME."
+  (or (guix-get-key-val guix-list-mark-alist name)
+      (error "Mark '%S' not found" name)))
+
+(defsubst guix-list-get-mark-string (name)
+  "Return mark string by its NAME."
+  (string (guix-list-get-mark name)))
+
+(defun guix-list-current-mark ()
+  "Return mark character of the current line."
+  (char-after (line-beginning-position)))
+
+(defun guix-list-get-marked (&rest mark-names)
+  "Return list of specs of entries marked with any mark from MARK-NAMES.
+Entry specs are elements from `guix-list-marked' list.
+If MARK-NAMES are not specified, use all marks from
+`guix-list-mark-alist' except the `empty' one."
+  (or mark-names
+      (setq mark-names
+            (delq 'empty
+                  (mapcar #'car guix-list-mark-alist))))
+  (cl-remove-if-not (lambda (assoc)
+                      (memq (cadr assoc) mark-names))
+                    guix-list-marked))
+
+(defun guix-list-get-marked-args (mark-name)
+  "Return list of (ID . ARGS) elements from lines marked with MARK-NAME.
+See `guix-list-marked' for the meaning of ARGS."
+  (mapcar (lambda (spec)
+            (let ((id (car spec))
+                  (args (cddr spec)))
+              (cons id args)))
+          (guix-list-get-marked mark-name)))
+
+(defun guix-list-get-marked-id-list (&rest mark-names)
+  "Return list of IDs of entries marked with any mark from MARK-NAMES.
+See `guix-list-get-marked' for details."
+  (mapcar #'car (apply #'guix-list-get-marked mark-names)))
+
+(defun guix-list-mark (mark-name &optional advance &rest args)
+  "Put a mark on the current line.
+Also add the current entry to `guix-list-marked' using its ID and ARGS.
+MARK-NAME is a symbol from `guix-list-mark-alist'.
+If ADVANCE is non-nil, move forward by one line after marking.
+Interactively, put a general mark and move to the next line."
+  (interactive '(general t))
+  (let ((id (guix-list-current-id)))
+    (if (eq mark-name 'empty)
+        (setq guix-list-marked (assq-delete-all id guix-list-marked))
+      (let ((assoc (assq id guix-list-marked))
+            (val (cons mark-name args)))
+        (if assoc
+            (setcdr assoc val)
+          (push (cons id val) guix-list-marked)))))
+  (tabulated-list-put-tag (guix-list-get-mark-string mark-name)
+                          advance))
+
+(defun guix-list-mark-all (mark-name)
+  "Mark all lines with MARK-NAME mark.
+MARK-NAME is a symbol from `guix-list-mark-alist'.
+Interactively, put a general mark on all lines."
+  (interactive '(general))
+  (guix-list-for-each-line #'guix-list-mark mark-name))
+
+(defun guix-list-unmark ()
+  "Unmark the current line and move to the next line."
+  (interactive)
+  (guix-list-mark 'empty t))
+
+(defun guix-list-unmark-backward ()
+  "Move up one line and unmark it."
+  (interactive)
+  (forward-line -1)
+  (guix-list-mark 'empty))
+
+(defun guix-list-unmark-all ()
+  "Unmark all lines."
+  (interactive)
+  (guix-list-mark-all 'empty))
+
+(defun guix-list-restore-marks ()
+  "Put marks according to `guix-list-mark-alist'."
+  (guix-list-for-each-line
+   (lambda ()
+     (let ((mark-name (car (guix-get-key-val guix-list-marked
+                                             (guix-list-current-id)))))
+       (tabulated-list-put-tag
+        (guix-list-get-mark-string (or mark-name 'empty)))))))
+
+(defun guix-list-sort (&optional n)
+  "Sort guix list entries by the column at point.
+With a numeric prefix argument N, sort the Nth column.
+Same as `tabulated-list-sort', but also restore marks after sorting."
+  (interactive "P")
+  (tabulated-list-sort n)
+  (guix-list-restore-marks))
+
+
+(defvar guix-list-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map tabulated-list-mode-map)
+    (define-key map (kbd "m")   'guix-list-mark)
+    (define-key map (kbd "*")   'guix-list-mark)
+    (define-key map (kbd "M")   'guix-list-mark-all)
+    (define-key map (kbd "u")   'guix-list-unmark)
+    (define-key map (kbd "U")   'guix-list-unmark-all)
+    (define-key map (kbd "DEL") 'guix-list-unmark-backward)
+    (define-key map [remap tabulated-list-sort] 'guix-list-sort)
+    map)
+  "Parent keymap for list buffers.")
+
+(define-derived-mode guix-list-mode tabulated-list-mode "Guix-List"
+  "Parent mode for displaying information in list buffers."
+  (setq tabulated-list-padding 2))
+
+(defmacro guix-list-define-entry-type (entry-type &rest args)
+  "Define common stuff for displaying ENTRY-TYPE entries in list buffers.
+
+Remaining argument (ARGS) should have a form [KEYWORD VALUE] ...  The
+following keywords are available:
+
+  - `:sort-key' - default sort key for the tabulated list buffer.
+
+  - `:invert-sort' - if non-nil, invert initial sort.
+
+  - `:marks' - default value for the defined
+    `guix-ENTRY-TYPE-mark-alist' variable.
+
+This macro defines the following functions:
+
+  - `guix-ENTRY-TYPE-describe' - display marked entries in info buffer.
+
+  - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark
+    specified in `:marks' argument."
+  (let* ((entry-type-str (symbol-name entry-type))
+         (entry-str      (concat entry-type-str " entries"))
+         (prefix         (concat "guix-" entry-type-str "-list"))
+         (mode-str       (concat prefix "-mode"))
+         (init-fun       (intern (concat prefix "-mode-initialize")))
+         (describe-fun   (intern (concat prefix "-describe")))
+         (marks-var      (intern (concat prefix "-mark-alist")))
+         (marks-val      nil)
+         (sort-key       nil)
+         (invert-sort    nil))
+
+    ;; Process the keyword args.
+    (while (keywordp (car args))
+      (pcase (pop args)
+        (`:sort-key    (setq sort-key (pop args)))
+        (`:invert-sort (setq invert-sort (pop args)))
+	(`:marks       (setq marks-val (pop args)))
+	(_ (pop args))))
+
+    `(progn
+       (defvar ,marks-var ',marks-val
+         ,(concat "Alist of additional marks for `" mode-str "'.\n"
+                  "Marks from this list are added to `guix-list-mark-alist'."))
+
+       ,@(mapcar (lambda (mark-spec)
+                   (let* ((mark-name (car mark-spec))
+                          (mark-name-str (symbol-name mark-name)))
+                     `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) ()
+                        ,(concat "Put '" mark-name-str "' mark and move to the next line.\n"
+                                 "Also add the current entry to `guix-list-marked'.")
+                        (interactive)
+                        (guix-list-mark ',mark-name t))))
+                 marks-val)
+
+       (defun ,describe-fun (&optional arg)
+         ,(concat "Describe " entry-str " marked with a general mark.\n"
+                  "If no entry is marked, describe the current " entry-type-str ".\n"
+                  "With prefix (if ARG is non-nil), describe the " entry-str "\n"
+                  "marked with any mark.")
+         (interactive "P")
+         (let* ((ids (or (apply #'guix-list-get-marked-id-list
+                                (unless arg '(general)))
+                         (list (guix-list-current-id))))
+                (count (length ids)))
+           (when (or (<= count guix-list-describe-warning-count)
+                     (y-or-n-p (format "Do you really want to describe %d entries? "
+                                       count)))
+             (,(intern (concat "guix-" entry-type-str "-info-get-show"))
+              'id ids))))
+
+       (defun ,init-fun ()
+         ,(concat "Initial settings for `" mode-str "'.")
+         ,(when sort-key
+            `(setq tabulated-list-sort-key
+                   (guix-list-get-sort-key
+                    ',entry-type ',sort-key ,invert-sort)))
+         (setq tabulated-list-format
+               (guix-list-get-list-format ',entry-type))
+         (setq-local guix-list-mark-alist
+                     (append guix-list-mark-alist ,marks-var))
+         (tabulated-list-init-header)))))
+
+(put 'guix-list-define-entry-type 'lisp-indent-function 'defun)
+
+
+;;; Displaying packages
+
+(guix-define-buffer-type list package)
+
+(guix-list-define-entry-type package
+  :sort-key name
+  :marks ((install . ?I)
+          (upgrade . ?U)
+          (delete  . ?D)))
+
+(defface guix-package-list-installed
+  '((t :inherit guix-package-info-installed-outputs))
+  "Face used if there are installed outputs for the current package."
+  :group 'guix-package-list)
+
+(defface guix-package-list-obsolete
+  '((t :inherit guix-package-info-obsolete))
+  "Face used if a package is obsolete."
+  :group 'guix-package-list)
+
+(defcustom guix-package-list-generation-marking-enabled nil
+  "If non-nil, allow putting marks in a list with 'generation packages'.
+
+By default this is disabled, because it may be confusing.  For
+example a package is installed in some generation, so a user can
+mark it for deletion in the list of packages from this
+generation, but the package may not be installed in the latest
+generation, so actually it cannot be deleted.
+
+If you managed to understand the explanation above or if you
+really know what you do or if you just don't care, you can set
+this variable to t.  It should not do much harm anyway (most
+likely)."
+  :type 'boolean
+  :group 'guix-package-list)
+
+(let ((map guix-package-list-mode-map))
+  (define-key map (kbd "RET") 'guix-package-list-describe)
+  (define-key map (kbd "x")   'guix-package-list-execute)
+  (define-key map (kbd "i")   'guix-package-list-mark-install)
+  (define-key map (kbd "^")   'guix-package-list-mark-upgrade)
+  (define-key map (kbd "d")   'guix-package-list-mark-delete))
+
+(defun guix-package-list-get-name (name entry)
+  "Return NAME of the package ENTRY.
+Colorize it with `guix-package-list-installed' or
+`guix-package-list-obsolete' if needed."
+  (guix-get-string name
+                   (cond ((guix-get-key-val entry 'obsolete)
+                          'guix-package-list-obsolete)
+                         ((guix-get-key-val entry 'installed)
+                          'guix-package-list-installed))))
+
+(defun guix-package-list-get-installed-outputs (installed &optional _)
+  "Return string with outputs from INSTALLED entries."
+  (guix-get-string
+   (mapcar (lambda (entry)
+             (guix-get-key-val entry 'output))
+           installed)))
+
+(defun guix-package-list-marking-check ()
+  "Signal an error if marking is disabled for the current buffer."
+  (when (and (not guix-package-list-generation-marking-enabled)
+             (derived-mode-p 'guix-package-list-mode)
+             (eq guix-search-type 'generation))
+    (error "Action marks are disabled for lists of 'generation packages'")))
+
+(defun guix-package-list-mark-install (&optional arg)
+  "Mark the current package for installation and move to the next line.
+With ARG, prompt for the outputs to install (several outputs may
+be separated with \",\")."
+  (interactive "P")
+  (guix-package-list-marking-check)
+  (let* ((entry (guix-list-current-entry))
+         (available (guix-get-key-val entry 'outputs))
+         (installed (guix-get-installed-outputs entry))
+         (to-install (if arg
+                         (guix-completing-read-multiple
+                          "Output(s) to install: " available nil t)
+                       '("out")))
+         (to-install (cl-set-difference to-install installed
+                                        :test #'string=)))
+    (if to-install
+        (apply #'guix-list-mark 'install t to-install)
+      (user-error "This package is already installed"))))
+
+(defun guix-package-list-mark-delete (&optional arg)
+  "Mark the current package for deletion and move to the next line.
+With ARG, prompt for the outputs to delete (several outputs may
+be separated with \",\")."
+  (interactive "P")
+  (guix-package-list-marking-check)
+  (let* ((entry (guix-list-current-entry))
+         (installed (guix-get-installed-outputs entry)))
+    (or installed
+        (user-error "This package is not installed"))
+    (let ((to-delete (when arg
+                       (guix-completing-read-multiple
+                        "Output(s) to delete: " installed nil t))))
+      (if to-delete
+          (apply #'guix-list-mark 'delete t to-delete)
+        (guix-package-list-mark-delete-simple)))))
+
+(defun guix-package-list-mark-upgrade ()
+  "Mark the current package for upgrading and move to the next line."
+  (interactive)
+  (guix-package-list-marking-check)
+  (let ((entry (guix-list-current-entry)))
+    (or (guix-get-installed-outputs entry)
+        (user-error "This package is not installed"))
+    (when (or (guix-get-key-val entry 'obsolete)
+              (y-or-n-p "This package is not obsolete.  Try to upgrade it anyway? "))
+      (guix-package-list-mark-upgrade-simple))))
+
+(defun guix-package-list-execute ()
+  "Perform actions on the marked packages."
+  (interactive)
+  (let ((actions (delq nil
+                       (mapcar #'guix-package-list-make-action
+                               '(install delete upgrade)))))
+    (if actions
+        (apply #'guix-process-package-actions actions)
+      (user-error "No operations specified"))))
+
+(defun guix-package-list-make-action (action-type)
+  "Return action specification for the packages marked with ACTION-TYPE.
+Return nil, if there are no packages marked with ACTION-TYPE.
+The specification is suitable for `guix-process-package-actions'."
+  (let ((specs (guix-list-get-marked-args action-type)))
+    (and specs (cons action-type specs))))
+
+
+;;; Displaying generations
+
+(guix-define-buffer-type list generation)
+
+(guix-list-define-entry-type generation
+  :sort-key number
+  :invert-sort t
+  :marks ((delete . ?D)))
+
+(let ((map guix-generation-list-mode-map))
+  (define-key map (kbd "RET") 'guix-generation-list-show-packages)
+  (define-key map (kbd "i")   'guix-generation-list-describe)
+  (define-key map (kbd "d")   'guix-generation-list-mark-delete-simple))
+
+(defun guix-generation-list-show-packages ()
+  "List installed packages for the generation at point."
+  (interactive)
+  (guix-package-list-get-show 'generation (guix-list-current-id)))
+
+(provide 'guix-list)
+
+;;; guix-list.el ends here

emacs/guix-main.scm

@@ -0,0 +1,603 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Information about packages and generations is passed to the elisp
+;; side in the form of alists of parameters (such as ‘name’ or
+;; ‘version’) and their values.  These alists are called "entries" in
+;; this code.  So to distinguish, just "package" in the name of a
+;; function means a guile object ("package" record) while
+;; "package entry" means alist of package parameters and values (see
+;; ‘package-param-alist’).
+;;
+;; "Entry" is probably not the best name for such alists, because there
+;; already exists "manifest-entry" which has nothing to do with the
+;; "entry" described above.  Do not be confused :)
+
+;; ‘get-entries’ function is the “entry point” for the elisp side to get
+;; information about packages and generations.
+
+;; Since name/version pair is not necessarily unique, we use
+;; `object-address' to identify a package (for ‘id’ parameter), if
+;; possible.  However for the obsolete packages (that can be found in
+;; installed manifest but not in a package directory), ‘id’ parameter is
+;; still "name-version" string.  So ‘id’ package parameter in the code
+;; below is either an object-address number or a full-name string.
+;;
+;; Important: as object addresses live only during guile session, elisp
+;; part should take care about updating information after "Guix REPL" is
+;; restarted (TODO!)
+;;
+;; ‘installed’ parameter of a package entry contains information about
+;; installed outputs.  It is a list of "installed entries" (see
+;; ‘package-installed-param-alist’).
+
+;; To speed-up the process of getting information, the following
+;; auxiliary variables are used:
+;;
+;; - `%packages' - VHash of "package address"/"package" pairs.
+;;
+;; - `%package-table' - Hash table of
+;;   "name+version key"/"list of packages" pairs.
+;;
+;; - `%current-manifest-entries-table' - Hash table of
+;;   "name+version key"/"list of manifest entries" pairs.  This variable
+;;   is set by `set-current-manifest-maybe!' when it is needed.
+
+;;; Code:
+
+(use-modules
+ (ice-9 vlist)
+ (ice-9 match)
+ (srfi srfi-1)
+ (srfi srfi-11)
+ (srfi srfi-19)
+ (srfi srfi-26)
+ (guix)
+ (guix packages)
+ (guix profiles)
+ (guix licenses)
+ (guix utils)
+ (guix ui)
+ (guix scripts package)
+ (gnu packages))
+
+(define-syntax-rule (first-or-false lst)
+  (and (not (null? lst))
+       (first lst)))
+
+(define full-name->name+version package-name->name+version)
+(define (name+version->full-name name version)
+  (string-append name "-" version))
+
+(define* (make-package-specification name #:optional version output)
+  (let ((full-name (if version
+                       (name+version->full-name name version)
+                       name)))
+    (if output
+        (string-append full-name ":" output)
+        full-name)))
+
+(define name+version->key cons)
+(define key->name+version car+cdr)
+
+(define %current-manifest #f)
+(define %current-manifest-entries-table #f)
+
+(define %packages
+  (fold-packages (lambda (pkg res)
+                   (vhash-consq (object-address pkg) pkg res))
+                 vlist-null))
+
+(define %package-table
+  (let ((table (make-hash-table (vlist-length %packages))))
+    (vlist-for-each
+     (lambda (elem)
+       (match elem
+         ((address . pkg)
+          (let* ((key (name+version->key (package-name pkg)
+                                         (package-version pkg)))
+                 (ref (hash-ref table key)))
+            (hash-set! table key
+                       (if ref (cons pkg ref) (list pkg)))))))
+     %packages)
+    table))
+
+;; FIXME get rid of this function!
+(define (set-current-manifest-maybe! profile)
+  (define (manifest-entries->hash-table entries)
+    (let ((entries-table (make-hash-table (length entries))))
+      (for-each (lambda (entry)
+                  (let* ((key (name+version->key
+                               (manifest-entry-name entry)
+                               (manifest-entry-version entry)))
+                         (ref (hash-ref entries-table key)))
+                    (hash-set! entries-table key
+                               (if ref (cons entry ref) (list entry)))))
+                entries)
+      entries-table))
+
+  (when profile
+    (let ((manifest (profile-manifest profile)))
+      (unless (and (manifest? %current-manifest)
+                   (equal? manifest %current-manifest))
+        (set! %current-manifest manifest)
+        (set! %current-manifest-entries-table
+              (manifest-entries->hash-table
+               (manifest-entries manifest)))))))
+
+(define (manifest-entries-by-name+version name version)
+  (or (hash-ref %current-manifest-entries-table
+                (name+version->key name version))
+      '()))
+
+(define (packages-by-name+version name version)
+  (or (hash-ref %package-table
+                (name+version->key name version))
+      '()))
+
+(define (packages-by-full-name full-name)
+  (call-with-values
+      (lambda () (full-name->name+version full-name))
+    packages-by-name+version))
+
+(define (package-by-address address)
+  (and=> (vhash-assq address %packages)
+         cdr))
+
+(define (packages-by-id id)
+  (if (integer? id)
+      (let ((pkg (package-by-address id)))
+        (if pkg (list pkg) '()))
+      (packages-by-full-name id)))
+
+(define (package-by-id id)
+  (first-or-false (packages-by-id id)))
+
+(define (newest-package-by-id id)
+  (and=> (id->name+version id)
+         (lambda (name)
+           (first-or-false (find-best-packages-by-name name #f)))))
+
+(define (id->name+version id)
+  (if (integer? id)
+      (and=> (package-by-address id)
+             (lambda (pkg)
+               (values (package-name pkg)
+                       (package-version pkg))))
+      (full-name->name+version id)))
+
+(define (fold-manifest-entries proc init)
+  "Fold over `%current-manifest-entries-table'.
+Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash
+table, using INIT as the initial value of RESULT."
+  (hash-fold (lambda (key entries res)
+               (let-values (((name version) (key->name+version key)))
+                 (proc name version entries res)))
+             init
+             %current-manifest-entries-table))
+
+(define (fold-object proc init obj)
+  (fold proc init
+        (if (list? obj) obj (list obj))))
+
+(define* (object-transformer param-alist #:optional (params '()))
+  "Return function for transforming an object into alist of parameters/values.
+
+PARAM-ALIST is alist of available object parameters (symbols) and functions
+returning values of these parameters.  Each function is called with object as
+a single argument.
+
+PARAMS is list of parameters from PARAM-ALIST that should be returned by a
+resulting function.  If PARAMS is not specified or is an empty list, use all
+available parameters.
+
+Example:
+
+  (let ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>))))
+        (number->alist (object-transformer alist '(plus1 mul2))))
+    (number->alist 8))
+  =>
+  ((plus1 . 9) (mul2 . 16))
+"
+  (let ((alist (let ((use-all-params (null? params)))
+                 (filter-map (match-lambda
+                              ((param . fun)
+                               (and (or use-all-params
+                                        (memq param params))
+                                    (cons param fun)))
+                              (_ #f))
+                             param-alist))))
+    (lambda (object)
+      (map (match-lambda
+            ((param . fun)
+             (cons param (fun object))))
+           alist))))
+
+(define package-installed-param-alist
+  (list
+   (cons 'output       manifest-entry-output)
+   (cons 'path         manifest-entry-item)
+   (cons 'dependencies manifest-entry-dependencies)))
+
+(define manifest-entry->installed-entry
+  (object-transformer package-installed-param-alist))
+
+(define (manifest-entries->installed-entries entries)
+  (map manifest-entry->installed-entry entries))
+
+(define (installed-entries-by-name+version name version)
+  (manifest-entries->installed-entries
+   (manifest-entries-by-name+version name version)))
+
+(define (installed-entries-by-package package)
+  (installed-entries-by-name+version (package-name package)
+                                     (package-version package)))
+
+(define (package-inputs-names inputs)
+  "Return list of full names of the packages from package INPUTS."
+  (filter-map (match-lambda
+               ((_ (? package? package))
+                (package-full-name package))
+               (_ #f))
+              inputs))
+
+(define (package-license-names package)
+  "Return list of license names of the PACKAGE."
+  (fold-object (lambda (license res)
+                 (if (license? license)
+                     (cons (license-name license) res)
+                     res))
+               '()
+               (package-license package)))
+
+(define (package-unique? package)
+  "Return #t if PACKAGE is a single package with such name/version."
+  (null? (cdr (packages-by-name+version (package-name package)
+                                        (package-version package)))))
+
+(define package-param-alist
+  (list
+   (cons 'id                object-address)
+   (cons 'name              package-name)
+   (cons 'version           package-version)
+   (cons 'license           package-license-names)
+   (cons 'synopsis          package-synopsis)
+   (cons 'description       package-description)
+   (cons 'home-url          package-home-page)
+   (cons 'outputs           package-outputs)
+   (cons 'non-unique        (negate package-unique?))
+   (cons 'inputs            (lambda (pkg) (package-inputs-names
+                                      (package-inputs pkg))))
+   (cons 'native-inputs     (lambda (pkg) (package-inputs-names
+                                      (package-native-inputs pkg))))
+   (cons 'propagated-inputs (lambda (pkg) (package-inputs-names
+                                      (package-propagated-inputs pkg))))
+   (cons 'location          (lambda (pkg) (location->string
+                                      (package-location pkg))))
+   (cons 'installed         installed-entries-by-package)))
+
+(define (package-param package param)
+  "Return the value of a PACKAGE PARAM."
+  (define (accessor param)
+    (and=> (assq param package-param-alist)
+           cdr))
+  (and=> (accessor param)
+         (cut <> package)))
+
+(define (matching-package-entries ->entry predicate)
+  "Return list of package entries for the matching packages.
+PREDICATE is called on each package."
+  (fold-packages (lambda (pkg res)
+                   (if (predicate pkg)
+                       (cons (->entry pkg) res)
+                       res))
+                 '()))
+
+(define (make-obsolete-package-entry name version entries)
+  "Return package entry for an obsolete package with NAME and VERSION.
+ENTRIES is a list of manifest entries used to get installed info."
+  `((id        . ,(name+version->full-name name version))
+    (name      . ,name)
+    (version   . ,version)
+    (outputs   . ,(map manifest-entry-output entries))
+    (obsolete  . #t)
+    (installed . ,(manifest-entries->installed-entries entries))))
+
+(define (package-entries-by-name+version ->entry name version)
+  "Return list of package entries for packages with NAME and VERSION."
+  (let ((packages (packages-by-name+version name version)))
+    (if (null? packages)
+        (let ((entries (manifest-entries-by-name+version name version)))
+          (if (null? entries)
+              '()
+              (list (make-obsolete-package-entry name version entries))))
+        (map ->entry packages))))
+
+(define (package-entries-by-spec profile ->entry spec)
+  "Return list of package entries for packages with name specification SPEC."
+  (set-current-manifest-maybe! profile)
+  (let-values (((name version)
+                (full-name->name+version spec)))
+    (if version
+        (package-entries-by-name+version ->entry name version)
+        (matching-package-entries
+         ->entry
+         (lambda (pkg) (string=? name (package-name pkg)))))))
+
+(define (package-entries-by-regexp profile ->entry regexp match-params)
+  "Return list of package entries for packages matching REGEXP string.
+MATCH-PARAMS is a list of parameters that REGEXP can match."
+  (define (package-match? package regexp)
+    (any (lambda (param)
+           (let ((val (package-param package param)))
+             (and (string? val) (regexp-exec regexp val))))
+         match-params))
+
+  (set-current-manifest-maybe! profile)
+  (let ((re (make-regexp regexp regexp/icase)))
+    (matching-package-entries ->entry (cut package-match? <> re))))
+
+(define (package-entries-by-ids profile ->entry ids)
+  "Return list of package entries for packages matching KEYS.
+IDS may be an object-address, a full-name or a list of such elements."
+  (set-current-manifest-maybe! profile)
+  (fold-object
+   (lambda (id res)
+     (if (integer? id)
+         (let ((pkg (package-by-address id)))
+           (if pkg
+               (cons (->entry pkg) res)
+               res))
+         (let ((entries (package-entries-by-spec #f ->entry id)))
+           (if (null? entries)
+               res
+               (append res entries)))))
+   '()
+   ids))
+
+(define (newest-available-package-entries profile ->entry)
+  "Return list of package entries for the newest available packages."
+  (set-current-manifest-maybe! profile)
+  (vhash-fold (lambda (name elem res)
+                (match elem
+                  ((version newest pkgs ...)
+                   (cons (->entry newest) res))))
+              '()
+              (find-newest-available-packages)))
+
+(define (all-available-package-entries profile ->entry)
+  "Return list of package entries for all available packages."
+  (set-current-manifest-maybe! profile)
+  (matching-package-entries ->entry (const #t)))
+
+(define (manifest-package-entries ->entry)
+  "Return list of package entries for the current manifest."
+  (fold-manifest-entries
+   (lambda (name version entries res)
+     ;; We don't care about duplicates for the list of
+     ;; installed packages, so just take any package (car)
+     ;; matching name+version
+     (cons (car (package-entries-by-name+version ->entry name version))
+           res))
+   '()))
+
+(define (installed-package-entries profile ->entry)
+  "Return list of package entries for all installed packages."
+  (set-current-manifest-maybe! profile)
+  (manifest-package-entries ->entry))
+
+(define (generation-package-entries profile ->entry generation)
+  "Return list of package entries for packages from GENERATION."
+  (set-current-manifest-maybe!
+   (generation-file-name profile generation))
+  (manifest-package-entries ->entry))
+
+(define (obsolete-package-entries profile _)
+  "Return list of package entries for obsolete packages."
+  (set-current-manifest-maybe! profile)
+  (fold-manifest-entries
+   (lambda (name version entries res)
+     (let ((packages (packages-by-name+version name version)))
+       (if (null? packages)
+           (cons (make-obsolete-package-entry name version entries) res)
+           res)))
+   '()))
+
+
+;;; Generation entries
+
+(define (profile-generations profile)
+  "Return list of generations for PROFILE."
+  (let ((generations (generation-numbers profile)))
+    (if (equal? generations '(0))
+        '()
+        generations)))
+
+(define (generation-param-alist profile)
+  "Return alist of generation parameters and functions for PROFILE."
+  (list
+   (cons 'id          identity)
+   (cons 'number      identity)
+   (cons 'prev-number (cut previous-generation-number profile <>))
+   (cons 'path        (cut generation-file-name profile <>))
+   (cons 'time        (lambda (gen)
+                        (time-second (generation-time profile gen))))))
+
+(define (matching-generation-entries profile ->entry predicate)
+  "Return list of generation entries for the matching generations.
+PREDICATE is called on each generation."
+  (filter-map (lambda (gen)
+                (and (predicate gen) (->entry gen)))
+              (profile-generations profile)))
+
+(define (last-generation-entries profile ->entry number)
+  "Return list of last NUMBER generation entries.
+If NUMBER is 0 or less, return all generation entries."
+  (let ((generations (profile-generations profile))
+        (number (if (<= number 0) +inf.0 number)))
+    (map ->entry
+         (if (> (length generations) number)
+             (list-head  (reverse generations) number)
+             generations))))
+
+(define (all-generation-entries profile ->entry)
+  "Return list of all generation entries."
+  (last-generation-entries profile ->entry +inf.0))
+
+(define (generation-entries-by-ids profile ->entry ids)
+  "Return list of generation entries for generations matching IDS.
+IDS is a list of generation numbers."
+  (matching-generation-entries profile ->entry (cut memq <> ids)))
+
+
+;;; Getting package/generation entries
+
+(define %package-entries-functions
+  (alist->vhash
+   `((id               . ,package-entries-by-ids)
+     (name             . ,package-entries-by-spec)
+     (regexp           . ,package-entries-by-regexp)
+     (all-available    . ,all-available-package-entries)
+     (newest-available . ,newest-available-package-entries)
+     (installed        . ,installed-package-entries)
+     (obsolete         . ,obsolete-package-entries)
+     (generation       . ,generation-package-entries))
+   hashq))
+
+(define %generation-entries-functions
+  (alist->vhash
+   `((id   . ,generation-entries-by-ids)
+     (last . ,last-generation-entries)
+     (all  . ,all-generation-entries))
+   hashq))
+
+(define (get-entries profile params entry-type search-type search-vals)
+  "Return list of entries.
+ENTRY-TYPE and SEARCH-TYPE define a search function that should be
+applied to PARAMS and VALS."
+  (let-values (((vhash ->entry)
+                (case entry-type
+                  ((package)
+                   (values %package-entries-functions
+                           (object-transformer
+                            package-param-alist params)))
+                  ((generation)
+                   (values %generation-entries-functions
+                           (object-transformer
+                            (generation-param-alist profile) params)))
+                  (else (format (current-error-port)
+                                "Wrong entry type '~a'" entry-type)))))
+    (match (vhash-assq search-type vhash)
+      ((key . fun)
+       (apply fun profile ->entry search-vals))
+      (_ '()))))
+
+
+;;; Actions
+
+(define* (package->manifest-entry* package #:optional output)
+  (and package
+       (begin
+         (check-package-freshness package)
+         (package->manifest-entry package output))))
+
+(define* (make-install-manifest-entries id #:optional output)
+  (package->manifest-entry* (package-by-id id) output))
+
+(define* (make-upgrade-manifest-entries id #:optional output)
+  (package->manifest-entry* (newest-package-by-id id) output))
+
+(define* (make-manifest-pattern id #:optional output)
+  "Make manifest pattern from a package ID and OUTPUT."
+  (let-values (((name version)
+                (id->name+version id)))
+    (and name version
+         (manifest-pattern
+          (name name)
+          (version version)
+          (output output)))))
+
+(define (convert-action-pattern pattern proc)
+  "Convert action PATTERN into a list of objects returned by PROC.
+PROC is called: (PROC ID) or (PROC ID OUTPUT)."
+  (match pattern
+    ((id . outputs)
+     (if (null? outputs)
+         (let ((obj (proc id)))
+           (if obj (list obj) '()))
+         (filter-map (cut proc id <>)
+                     outputs)))
+    (_ '())))
+
+(define (convert-action-patterns patterns proc)
+  (append-map (cut convert-action-pattern <> proc)
+              patterns))
+
+(define* (process-package-actions
+          profile #:key (install '()) (upgrade '()) (remove '())
+          (use-substitutes? #t) dry-run?)
+  "Perform package actions.
+
+INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'.
+Each pattern should have the following form:
+
+  (ID . OUTPUTS)
+
+ID is an object address or a full-name of a package.
+OUTPUTS is a list of package outputs (may be an empty list)."
+  (format #t "The process begins ...~%")
+  (let* ((install (append
+                   (convert-action-patterns
+                    install make-install-manifest-entries)
+                   (convert-action-patterns
+                    upgrade make-upgrade-manifest-entries)))
+         (remove (convert-action-patterns remove make-manifest-pattern))
+         (transaction (manifest-transaction (install install)
+                                            (remove remove)))
+         (manifest (profile-manifest profile))
+         (new-manifest (manifest-perform-transaction
+                        manifest transaction)))
+    (unless (and (null? install) (null? remove))
+      (let* ((store (open-connection))
+             (derivation (run-with-store
+                          store (profile-derivation new-manifest)))
+             (derivations (list derivation))
+             (new-profile (derivation->output-path derivation)))
+        (set-build-options store
+                           #:use-substitutes? use-substitutes?)
+        (manifest-show-transaction store manifest transaction
+                                   #:dry-run? dry-run?)
+        (show-what-to-build store derivations
+                            #:use-substitutes? use-substitutes?
+                            #:dry-run? dry-run?)
+        (unless dry-run?
+          (let ((name (generation-file-name
+                       profile
+                       (+ 1 (generation-number profile)))))
+            (and (build-derivations store derivations)
+                 (let* ((entries (manifest-entries new-manifest))
+                        (count   (length entries)))
+                   (switch-symlinks name new-profile)
+                   (switch-symlinks profile name)
+                   (format #t (N_ "~a package in profile~%"
+                                  "~a packages in profile~%"
+                                  count)
+                           count)))))))))
+

emacs/guix-utils.el

@@ -0,0 +1,160 @@
+;;; guix-utils.el --- General utility functions
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides auxiliary general functions for guix.el package.
+
+;;; Code:
+
+;; (require 'cl-lib)
+
+(defvar guix-true-string "Yes")
+(defvar guix-false-string "–")
+(defvar guix-list-separator ", ")
+
+(defvar guix-time-format "%F %T"
+  "String used to format time values.
+For possible formats, see `format-time-string'.")
+
+(defun guix-get-string (val &optional face)
+  "Convert VAL into a string and return it.
+
+VAL can be an expression of any type.
+If VAL is t/nil, it is replaced with
+`guix-true-string'/`guix-false-string'.
+If VAL is list, its elements are concatenated using
+`guix-list-separator'.
+
+If FACE is non-nil, propertize returned string with this FACE."
+  (let ((str (cond
+              ((stringp val) val)
+              ((null val) guix-false-string)
+              ((eq t val) guix-true-string)
+              ((numberp val) (number-to-string val))
+              ((listp val) (mapconcat #'guix-get-string
+                                      val guix-list-separator))
+              (t (prin1-to-string val)))))
+    (if (and val face)
+        (propertize str 'face face)
+      str)))
+
+(defun guix-get-time-string (seconds)
+  "Return formatted time string from SECONDS.
+Use `guix-time-format'."
+  (format-time-string guix-time-format (seconds-to-time seconds)))
+
+(defun guix-get-one-line (str)
+  "Return one-line string from a multi-line STR."
+  (replace-regexp-in-string "\n" " " str))
+
+(defun guix-format-insert (val &optional face format)
+  "Convert VAL into a string and insert it at point.
+If FACE is non-nil, propertize VAL with FACE.
+If FORMAT is non-nil, format VAL with FORMAT."
+  (let ((str (guix-get-string val face)))
+    (insert (if format
+                (format format str)
+              str))))
+
+(defun guix-mapinsert (function sequence separator)
+  "Like `mapconcat' but for inserting text.
+Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR
+at point between each FUNCTION call."
+  (when sequence
+    (funcall function (car sequence))
+    (mapc (lambda (obj)
+            (insert separator)
+            (funcall function obj))
+          (cdr sequence))))
+
+(defun guix-insert-button (label face action &optional message
+                                 &rest properties)
+  "Make button with LABEL and insert it at point.
+Propertize button with FACE.
+ACTION is a function called when the button is pressed.  It
+should accept button as the argument.
+MESSAGE is a button message.
+See `insert-text-button' for the meaning of PROPERTIES."
+  (if (null label)
+      (guix-format-insert nil)
+    (apply #'insert-text-button
+           label
+           'face face
+           'action action
+           'follow-link t
+           'help-echo message
+           properties)))
+
+(defun guix-split-insert (val &optional face col separator)
+  "Convert VAL into a string, split it and insert at point.
+
+If FACE is non-nil, propertize returned string with this FACE.
+
+If COL is non-nil and result string is a one-line string longer
+than COL, split it into several short lines.
+
+Separate inserted lines with SEPARATOR."
+  (if (null val)
+      (guix-format-insert nil)
+    (let ((strings (guix-split-string (guix-get-string val) col)))
+      (guix-mapinsert (lambda (str) (guix-format-insert str face))
+                      strings
+                      (or separator "")))))
+
+(defun guix-split-string (str &optional col)
+  "Split string STR by lines and return list of result strings.
+If COL is non-nil and STR is a one-line string longer than COL,
+split it into several short lines."
+  (let ((strings (split-string str "\n *")))
+    (if (and col
+             (null (cdr strings))       ; if not multi-line
+             (> (length str) col))
+        (split-string (guix-get-filled-string str col) "\n")
+      strings)))
+
+(defun guix-get-filled-string (str col)
+  "Return string by filling STR to column COL."
+  (with-temp-buffer
+    (insert str)
+    (let ((fill-column col))
+      (fill-region (point-min) (point-max)))
+    (buffer-string)))
+
+(defun guix-completing-read-multiple (prompt table &optional predicate
+                                      require-match initial-input
+                                      hist def inherit-input-method)
+  "Same as `completing-read-multiple' but remove duplicates in result."
+  (cl-remove-duplicates
+   (completing-read-multiple prompt table predicate
+                             require-match initial-input
+                             hist def inherit-input-method)
+   :test #'string=))
+
+(defun guix-get-key-val (alist &rest keys)
+  "Return value from ALIST by KEYS.
+ALIST is alist of alists of alists ... which can be consecutively
+accessed with KEYS."
+  (let ((val alist))
+    (dolist (key keys val)
+      (setq val (cdr (assq key val))))))
+
+(provide 'guix-utils)
+
+;;; guix-utils.el ends here

emacs/guix.el

@@ -0,0 +1,141 @@
+;;; guix.el --- Interface for GNU Guix package manager
+
+;; Copyright © 2014 Alex Kost <alezost@gmail.com>
+
+;; Package-Requires: ((geiser "0.3"))
+;; Keywords: tools
+
+;; This file is part of GNU Guix.
+
+;; GNU Guix is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Guix is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides an interface for searching, listing and getting
+;; information about Guix packages and generations; and for
+;; installing/upgrading/removing packages.
+
+;;; Code:
+
+(require 'guix-list)
+(require 'guix-info)
+
+(defgroup guix nil
+  "Interface for Guix package manager."
+  :prefix "guix-"
+  :group 'external)
+
+(defcustom guix-list-single-package nil
+  "If non-nil, list a package even if it is the only matching result.
+If nil, show a single package in the info buffer."
+  :type 'boolean
+  :group 'guix)
+
+(defcustom guix-show-generations-function 'guix-generation-list-get-show
+  "Default function used to display generations."
+  :type '(choice (function-item guix-generation-list-get-show)
+                 (function-item guix-generation-info-get-show))
+  :group 'guix)
+
+(defvar guix-search-params '(name synopsis description)
+  "Default list of package parameters for searching by regexp.")
+
+(defvar guix-search-history nil
+  "A history of minibuffer prompts.")
+
+(defun guix-get-show-packages (search-type &rest search-vals)
+  "Search for packages and show results.
+
+See `guix-get-entries' for the meaning of SEARCH-TYPE and
+SEARCH-VALS.
+
+Results are displayed in the list buffer, unless a single package
+is found and `guix-list-single-package' is nil."
+  (let* ((list-params (guix-package-list-get-params-for-receiving))
+         (packages (guix-get-entries 'package search-type
+                                     search-vals list-params)))
+    (if (or guix-list-single-package
+            (cdr packages))
+        (guix-package-list-set packages search-type search-vals)
+      (let ((info-params (guix-package-info-get-params-for-receiving)))
+        (unless (equal list-params info-params)
+          ;; If we don't have required info, we should receive it again
+          (setq packages (guix-get-entries 'package search-type
+                                           search-vals info-params))))
+      (guix-package-info-set packages search-type search-vals))))
+
+(defun guix-get-show-generations (search-type &rest search-vals)
+  "Search for generations and show results."
+  (apply guix-show-generations-function search-type search-vals))
+
+;;;###autoload
+(defun guix-search-by-name (name)
+  "Search for Guix packages by NAME.
+NAME is a string with name specification.  It may optionally contain
+a version number.  Examples: \"guile\", \"guile-2.0.11\"."
+  (interactive
+   (list (read-string "Package name: " nil 'guix-search-history)))
+  (guix-get-show-packages 'name name))
+
+;;;###autoload
+(defun guix-search-by-regexp (regexp &rest params)
+  "Search for Guix packages by REGEXP.
+PARAMS are package parameters that should be searched.
+If PARAMS are not specified, use `guix-search-params'."
+  (interactive
+   (list (read-string "Regexp: " nil 'guix-search-history)))
+  (or params (setq params guix-search-params))
+  (guix-get-show-packages 'regexp regexp params))
+
+;;;###autoload
+(defun guix-installed-packages ()
+  "Display information about installed Guix packages."
+  (interactive)
+  (guix-get-show-packages 'installed))
+
+;;;###autoload
+(defun guix-obsolete-packages ()
+  "Display information about obsolete Guix packages."
+  (interactive)
+  (guix-get-show-packages 'obsolete))
+
+;;;###autoload
+(defun guix-all-available-packages ()
+  "Display information about all available Guix packages."
+  (interactive)
+  (guix-get-show-packages 'all-available))
+
+;;;###autoload
+(defun guix-newest-available-packages ()
+  "Display information about the newest available Guix packages."
+  (interactive)
+  (guix-get-show-packages 'newest-available))
+
+;;;###autoload
+(defun guix-generations (&optional number)
+  "Display information about last NUMBER generations.
+If NUMBER is nil, display all generations.
+
+Generations can be displayed in a list or info buffers depending
+on `guix-show-generations-function'.
+
+Interactively, NUMBER is defined by a numeric prefix."
+  (interactive "P")
+  (if (numberp number)
+      (guix-get-show-generations 'last number)
+    (guix-get-show-generations 'all)))
+
+(provide 'guix)
+
+;;; guix.el ends here

gnu-system.am

@@ -28,7 +28,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/acl.scm				\
   gnu/packages/admin.scm			\
   gnu/packages/algebra.scm			\
-  gnu/packages/aidc.scm 			\
+  gnu/packages/aidc.scm				\
   gnu/packages/apl.scm				\
   gnu/packages/apr.scm				\
   gnu/packages/asciidoc.scm			\
@@ -58,7 +58,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/compression.scm			\
   gnu/packages/complexity.scm			\
   gnu/packages/conkeror.scm			\
-  gnu/packages/cook.scm 			\
+  gnu/packages/cook.scm				\
   gnu/packages/cpio.scm				\
   gnu/packages/cppi.scm				\
   gnu/packages/cross-base.scm			\
@@ -151,7 +151,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/lightning.scm			\
   gnu/packages/links.scm			\
   gnu/packages/linux.scm			\
-  gnu/packages/lisp.scm			\
+  gnu/packages/lisp.scm				\
   gnu/packages/lout.scm				\
   gnu/packages/lsh.scm				\
   gnu/packages/lsof.scm				\
@@ -180,6 +180,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/nettle.scm			\
   gnu/packages/node.scm				\
   gnu/packages/noweb.scm			\
+  gnu/packages/nvi.scm				\
   gnu/packages/ocaml.scm			\
   gnu/packages/ocrad.scm			\
   gnu/packages/onc-rpc.scm			\
@@ -198,6 +199,7 @@ GNU_SYSTEM_MODULES =				\
   gnu/packages/pkg-config.scm			\
   gnu/packages/plotutils.scm			\
   gnu/packages/popt.scm				\
+  gnu/packages/postgresql.scm			\
   gnu/packages/pth.scm				\
   gnu/packages/pulseaudio.scm			\
   gnu/packages/pretty-print.scm			\
@@ -275,7 +277,15 @@ GNU_SYSTEM_MODULES =				\
   gnu/system/linux.scm				\
   gnu/system/linux-initrd.scm			\
   gnu/system/shadow.scm				\
-  gnu/system/vm.scm
+  gnu/system/vm.scm				\
+						\
+  gnu/build/activation.scm			\
+  gnu/build/file-systems.scm			\
+  gnu/build/install.scm				\
+  gnu/build/linux-boot.scm			\
+  gnu/build/linux-initrd.scm			\
+  gnu/build/vm.scm
+
 
 patchdir = $(guilemoduledir)/gnu/packages/patches
 dist_patch_DATA =						\
@@ -351,6 +361,7 @@ dist_patch_DATA =						\
   gnu/packages/patches/mit-krb5-init-fix.patch			\
   gnu/packages/patches/mpc123-initialize-ao.patch		\
   gnu/packages/patches/module-init-tools-moduledir.patch	\
+  gnu/packages/patches/nvi-assume-preserve-path.patch           \
   gnu/packages/patches/orpheus-cast-errors-and-includes.patch	\
   gnu/packages/patches/patchelf-page-size.patch			\
   gnu/packages/patches/patchutils-xfail-gendiff-tests.patch	\

gnu/build/activation.scm

@@ -16,9 +16,9 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (guix build activation)
+(define-module (gnu build activation)
+  #:use-module (gnu build linux-boot)
   #:use-module (guix build utils)
-  #:use-module (guix build linux-initrd)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)

gnu/build/file-systems.scm

@@ -0,0 +1,299 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build file-systems)
+  #:use-module (guix build utils)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (system foreign)
+  #:autoload   (system repl repl) (start-repl)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (disk-partitions
+            partition-label-predicate
+            find-partition-by-label
+            canonicalize-device-spec
+
+            MS_RDONLY
+            MS_NOSUID
+            MS_NODEV
+            MS_NOEXEC
+            MS_BIND
+            MS_MOVE
+            bind-mount
+
+            mount-flags->bit-mask
+            check-file-system
+            mount-file-system))
+
+;;; Commentary:
+;;;
+;;; This modules provides tools to deal with disk partitions, and to mount and
+;;; check file systems.
+;;;
+;;; Code:
+
+;; Linux mount flags, from libc's <sys/mount.h>.
+(define MS_RDONLY 1)
+(define MS_NOSUID 2)
+(define MS_NODEV  4)
+(define MS_NOEXEC 8)
+(define MS_BIND 4096)
+(define MS_MOVE 8192)
+
+(define (bind-mount source target)
+  "Bind-mount SOURCE at TARGET."
+  (mount source target "" MS_BIND))
+
+(define-syntax %ext2-endianness
+  ;; Endianness of ext2 file systems.
+  (identifier-syntax (endianness little)))
+
+;; Offset in bytes of interesting parts of an ext2 superblock.  See
+;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
+;; TODO: Use "packed structs" from Guile-OpenGL or similar.
+(define-syntax %ext2-sblock-magic       (identifier-syntax 56))
+(define-syntax %ext2-sblock-creator-os  (identifier-syntax 72))
+(define-syntax %ext2-sblock-uuid        (identifier-syntax 104))
+(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
+
+(define (read-ext2-superblock device)
+  "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
+if DEVICE does not contain an ext2 file system."
+  (define %ext2-magic
+    ;; The magic bytes that identify an ext2 file system.
+    #xef53)
+
+  (define superblock-size
+    ;; Size of the interesting part of an ext2 superblock.
+    264)
+
+  (define block
+    ;; The superblock contents.
+    (make-bytevector superblock-size))
+
+  (call-with-input-file device
+    (lambda (port)
+      (seek port 1024 SEEK_SET)
+
+      ;; Note: work around <http://bugs.gnu.org/17466>.
+      (and (eqv? superblock-size (get-bytevector-n! port block 0
+                                                    superblock-size))
+           (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
+                                            %ext2-endianness)))
+             (and (= magic %ext2-magic)
+                  block))))))
+
+(define (ext2-superblock-uuid sblock)
+  "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
+  (let ((uuid (make-bytevector 16)))
+    (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
+    uuid))
+
+(define (ext2-superblock-volume-name sblock)
+  "Return the volume name of SBLOCK as a string of at most 16 characters, or
+#f if SBLOCK has no volume name."
+  (let ((bv (make-bytevector 16)))
+    (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
+
+    ;; This is a Latin-1, nul-terminated string.
+    (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
+      (if (null? bytes)
+          #f
+          (list->string (map integer->char bytes))))))
+
+(define (disk-partitions)
+  "Return the list of device names corresponding to valid disk partitions."
+  (define (partition? major minor)
+    (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
+      (catch 'system-error
+        (lambda ()
+          (not (zero? (call-with-input-file marker read))))
+        (lambda args
+          (if (= ENOENT (system-error-errno args))
+              #f
+              (apply throw args))))))
+
+  (call-with-input-file "/proc/partitions"
+    (lambda (port)
+      ;; Skip the two header lines.
+      (read-line port)
+      (read-line port)
+
+      ;; Read each subsequent line, and extract the last space-separated
+      ;; field.
+      (let loop ((parts '()))
+        (let ((line  (read-line port)))
+          (if (eof-object? line)
+              (reverse parts)
+              (match (string-tokenize line)
+                (((= string->number major) (= string->number minor)
+                  blocks name)
+                 (if (partition? major minor)
+                     (loop (cons name parts))
+                     (loop parts))))))))))
+
+(define (partition-label-predicate label)
+  "Return a procedure that, when applied to a partition name such as \"sda1\",
+return #t if that partition's volume name is LABEL."
+  (lambda (part)
+    (let* ((device (string-append "/dev/" part))
+           (sblock (catch 'system-error
+                     (lambda ()
+                       (read-ext2-superblock device))
+                     (lambda args
+                       ;; When running on the hand-made /dev,
+                       ;; 'disk-partitions' could return partitions for which
+                       ;; we have no /dev node.  Handle that gracefully.
+                       (if (= ENOENT (system-error-errno args))
+                           (begin
+                             (format (current-error-port)
+                                     "warning: device '~a' not found~%"
+                                     device)
+                             #f)
+                           (apply throw args))))))
+      (and sblock
+           (let ((volume (ext2-superblock-volume-name sblock)))
+             (and volume
+                  (string=? volume label)))))))
+
+(define (find-partition-by-label label)
+  "Return the first partition found whose volume name is LABEL, or #f if none
+were found."
+  (and=> (find (partition-label-predicate label)
+               (disk-partitions))
+         (cut string-append "/dev/" <>)))
+
+(define* (canonicalize-device-spec spec #:optional (title 'any))
+  "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
+the following:
+
+  • 'device', in which case SPEC is known to designate a device node--e.g.,
+     \"/dev/sda1\";
+  • 'label', in which case SPEC is known to designate a partition label--e.g.,
+     \"my-root-part\";
+  • 'any', in which case SPEC can be anything.
+"
+  (define max-trials
+    ;; Number of times we retry partition label resolution, 1 second per
+    ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
+    ;; USB key would be detected by the kernel, so we must wait for at least
+    ;; this long.
+    20)
+
+  (define canonical-title
+    ;; The realm of canonicalization.
+    (if (eq? title 'any)
+        (if (string-prefix? "/" spec)
+            'device
+            'label)
+        title))
+
+  (case canonical-title
+    ((device)
+     ;; Nothing to do.
+     spec)
+    ((label)
+     ;; Resolve the label.
+     (let loop ((count 0))
+       (let ((device (find-partition-by-label spec)))
+         (or device
+             ;; Some devices take a bit of time to appear, most notably USB
+             ;; storage devices.  Thus, wait for the device to appear.
+             (if (> count max-trials)
+                 (error "failed to resolve partition label" spec)
+                 (begin
+                   (format #t "waiting for partition '~a' to appear...~%"
+                           spec)
+                   (sleep 1)
+                   (loop (+ 1 count))))))))
+    ;; TODO: Add support for UUIDs.
+    (else
+     (error "unknown device title" title))))
+
+(define (check-file-system device type)
+  "Run a file system check of TYPE on DEVICE."
+  (define fsck
+    (string-append "fsck." type))
+
+  (let ((status (system* fsck "-v" "-p" device)))
+    (match (status:exit-val status)
+      (0
+       #t)
+      (1
+       (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
+               fsck device))
+      (2
+       (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
+               fsck device)
+       (sleep 3)
+       (reboot))
+      (code
+       (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
+               fsck code device)
+       (start-repl)))))
+
+(define (mount-flags->bit-mask flags)
+  "Return the number suitable for the 'flags' argument of 'mount' that
+corresponds to the symbols listed in FLAGS."
+  (let loop ((flags flags))
+    (match flags
+      (('read-only rest ...)
+       (logior MS_RDONLY (loop rest)))
+      (('bind-mount rest ...)
+       (logior MS_BIND (loop rest)))
+      (('no-suid rest ...)
+       (logior MS_NOSUID (loop rest)))
+      (('no-dev rest ...)
+       (logior MS_NODEV (loop rest)))
+      (('no-exec rest ...)
+       (logior MS_NOEXEC (loop rest)))
+      (()
+       0))))
+
+(define* (mount-file-system spec #:key (root "/root"))
+  "Mount the file system described by SPEC under ROOT.  SPEC must have the
+form:
+
+  (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
+
+DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
+FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
+run a file system check."
+  (match spec
+    ((source title mount-point type (flags ...) options check?)
+     (let ((source      (canonicalize-device-spec source title))
+           (mount-point (string-append root "/" mount-point)))
+       (when check?
+         (check-file-system source type))
+       (mkdir-p mount-point)
+       (mount source mount-point type (mount-flags->bit-mask flags)
+              (if options
+                  (string->pointer options)
+                  %null-pointer))
+
+       ;; Update /etc/mtab.
+       (mkdir-p (string-append root "/etc"))
+       (let ((port (open-file (string-append root "/etc/mtab") "a")))
+         (format port "~a ~a ~a ~a 0 0~%"
+                 source mount-point type (or options ""))
+         (close-port port))))))
+
+;;; file-systems.scm ends here

gnu/build/install.scm

@@ -16,9 +16,8 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (guix build install)
+(define-module (gnu build install)
   #:use-module (guix build utils)
-  #:use-module (guix build install)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (install-grub

gnu/build/linux-boot.scm

@@ -16,35 +16,24 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (guix build linux-initrd)
+(define-module (gnu build linux-boot)
   #:use-module (rnrs io ports)
-  #:use-module (rnrs bytevectors)
-  #:use-module (system foreign)
   #:use-module (system repl error-handling)
   #:autoload   (system repl repl) (start-repl)
   #:autoload   (system base compile) (compile-file)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 rdelim)
   #:use-module (ice-9 ftw)
   #:use-module (guix build utils)
+  #:use-module (gnu build file-systems)
   #:export (mount-essential-file-systems
             linux-command-line
             find-long-option
             make-essential-device-nodes
             configure-qemu-networking
 
-            disk-partitions
-            partition-label-predicate
-            find-partition-by-label
-            canonicalize-device-spec
-
-            mount-flags->bit-mask
-            check-file-system
-            mount-file-system
             bind-mount
-
             load-linux-module*
             device-number
             boot-system))
@@ -99,172 +88,6 @@ Return the value associated with OPTION, or #f on failure."
            (lambda (arg)
              (substring arg (+ 1 (string-index arg #\=)))))))
 
-(define-syntax %ext2-endianness
-  ;; Endianness of ext2 file systems.
-  (identifier-syntax (endianness little)))
-
-;; Offset in bytes of interesting parts of an ext2 superblock.  See
-;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
-;; TODO: Use "packed structs" from Guile-OpenGL or similar.
-(define-syntax %ext2-sblock-magic       (identifier-syntax 56))
-(define-syntax %ext2-sblock-creator-os  (identifier-syntax 72))
-(define-syntax %ext2-sblock-uuid        (identifier-syntax 104))
-(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
-
-(define (read-ext2-superblock device)
-  "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
-if DEVICE does not contain an ext2 file system."
-  (define %ext2-magic
-    ;; The magic bytes that identify an ext2 file system.
-    #xef53)
-
-  (define superblock-size
-    ;; Size of the interesting part of an ext2 superblock.
-    264)
-
-  (define block
-    ;; The superblock contents.
-    (make-bytevector superblock-size))
-
-  (call-with-input-file device
-    (lambda (port)
-      (seek port 1024 SEEK_SET)
-
-      ;; Note: work around <http://bugs.gnu.org/17466>.
-      (and (eqv? superblock-size (get-bytevector-n! port block 0
-                                                    superblock-size))
-           (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
-                                            %ext2-endianness)))
-             (and (= magic %ext2-magic)
-                  block))))))
-
-(define (ext2-superblock-uuid sblock)
-  "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
-  (let ((uuid (make-bytevector 16)))
-    (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
-    uuid))
-
-(define (ext2-superblock-volume-name sblock)
-  "Return the volume name of SBLOCK as a string of at most 16 characters, or
-#f if SBLOCK has no volume name."
-  (let ((bv (make-bytevector 16)))
-    (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
-
-    ;; This is a Latin-1, nul-terminated string.
-    (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
-      (if (null? bytes)
-          #f
-          (list->string (map integer->char bytes))))))
-
-(define (disk-partitions)
-  "Return the list of device names corresponding to valid disk partitions."
-  (define (partition? major minor)
-    (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
-      (catch 'system-error
-        (lambda ()
-          (not (zero? (call-with-input-file marker read))))
-        (lambda args
-          (if (= ENOENT (system-error-errno args))
-              #f
-              (apply throw args))))))
-
-  (call-with-input-file "/proc/partitions"
-    (lambda (port)
-      ;; Skip the two header lines.
-      (read-line port)
-      (read-line port)
-
-      ;; Read each subsequent line, and extract the last space-separated
-      ;; field.
-      (let loop ((parts '()))
-        (let ((line  (read-line port)))
-          (if (eof-object? line)
-              (reverse parts)
-              (match (string-tokenize line)
-                (((= string->number major) (= string->number minor)
-                  blocks name)
-                 (if (partition? major minor)
-                     (loop (cons name parts))
-                     (loop parts))))))))))
-
-(define (partition-label-predicate label)
-  "Return a procedure that, when applied to a partition name such as \"sda1\",
-return #t if that partition's volume name is LABEL."
-  (lambda (part)
-    (let* ((device (string-append "/dev/" part))
-           (sblock (catch 'system-error
-                     (lambda ()
-                       (read-ext2-superblock device))
-                     (lambda args
-                       ;; When running on the hand-made /dev,
-                       ;; 'disk-partitions' could return partitions for which
-                       ;; we have no /dev node.  Handle that gracefully.
-                       (if (= ENOENT (system-error-errno args))
-                           (begin
-                             (format (current-error-port)
-                                     "warning: device '~a' not found~%"
-                                     device)
-                             #f)
-                           (apply throw args))))))
-      (and sblock
-           (let ((volume (ext2-superblock-volume-name sblock)))
-             (and volume
-                  (string=? volume label)))))))
-
-(define (find-partition-by-label label)
-  "Return the first partition found whose volume name is LABEL, or #f if none
-were found."
-  (and=> (find (partition-label-predicate label)
-               (disk-partitions))
-         (cut string-append "/dev/" <>)))
-
-(define* (canonicalize-device-spec spec #:optional (title 'any))
-  "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
-the following:
-
-  • 'device', in which case SPEC is known to designate a device node--e.g.,
-     \"/dev/sda1\";
-  • 'label', in which case SPEC is known to designate a partition label--e.g.,
-     \"my-root-part\";
-  • 'any', in which case SPEC can be anything.
-"
-  (define max-trials
-    ;; Number of times we retry partition label resolution, 1 second per
-    ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
-    ;; USB key would be detected by the kernel, so we must wait for at least
-    ;; this long.
-    20)
-
-  (define canonical-title
-    ;; The realm of canonicalization.
-    (if (eq? title 'any)
-        (if (string-prefix? "/" spec)
-            'device
-            'label)
-        title))
-
-  (case canonical-title
-    ((device)
-     ;; Nothing to do.
-     spec)
-    ((label)
-     ;; Resolve the label.
-     (let loop ((count 0))
-       (let ((device (find-partition-by-label spec)))
-         (or device
-             ;; Some devices take a bit of time to appear, most notably USB
-             ;; storage devices.  Thus, wait for the device to appear.
-             (if (> count max-trials)
-                 (error "failed to resolve partition label" spec)
-                 (begin
-                   (format #t "waiting for partition '~a' to appear...~%"
-                           spec)
-                   (sleep 1)
-                   (loop (+ 1 count))))))))
-    ;; TODO: Add support for UUIDs.
-    (else
-     (error "unknown device title" title))))
-
 (define* (make-disk-device-nodes base major #:optional (minor 0))
   "Make the block device nodes around BASE (something like \"/root/dev/sda\")
 with the given MAJOR number, starting with MINOR."
@@ -395,18 +218,6 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 
     (logand (network-interface-flags sock interface) IFF_UP)))
 
-;; Linux mount flags, from libc's <sys/mount.h>.
-(define MS_RDONLY 1)
-(define MS_NOSUID 2)
-(define MS_NODEV  4)
-(define MS_NOEXEC 8)
-(define MS_BIND 4096)
-(define MS_MOVE 8192)
-
-(define (bind-mount source target)
-  "Bind-mount SOURCE at TARGET."
-  (mount source target "" MS_BIND))
-
 (define (load-linux-module* file)
   "Load Linux module from FILE, the name of a `.ko' file."
   (define (slurp module)
@@ -479,74 +290,6 @@ UNIONFS."
 
   (copy-file "/proc/mounts" "/root/etc/mtab"))
 
-(define (check-file-system device type)
-  "Run a file system check of TYPE on DEVICE."
-  (define fsck
-    (string-append "fsck." type))
-
-  (let ((status (system* fsck "-v" "-p" device)))
-    (match (status:exit-val status)
-      (0
-       #t)
-      (1
-       (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
-               fsck device))
-      (2
-       (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
-               fsck device)
-       (sleep 3)
-       (reboot))
-      (code
-       (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
-               fsck code device)
-       (start-repl)))))
-
-(define (mount-flags->bit-mask flags)
-  "Return the number suitable for the 'flags' argument of 'mount' that
-corresponds to the symbols listed in FLAGS."
-  (let loop ((flags flags))
-    (match flags
-      (('read-only rest ...)
-       (logior MS_RDONLY (loop rest)))
-      (('bind-mount rest ...)
-       (logior MS_BIND (loop rest)))
-      (('no-suid rest ...)
-       (logior MS_NOSUID (loop rest)))
-      (('no-dev rest ...)
-       (logior MS_NODEV (loop rest)))
-      (('no-exec rest ...)
-       (logior MS_NOEXEC (loop rest)))
-      (()
-       0))))
-
-(define* (mount-file-system spec #:key (root "/root"))
-  "Mount the file system described by SPEC under ROOT.  SPEC must have the
-form:
-
-  (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
-
-DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
-FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
-run a file system check."
-  (match spec
-    ((source title mount-point type (flags ...) options check?)
-     (let ((source      (canonicalize-device-spec source title))
-           (mount-point (string-append root "/" mount-point)))
-       (when check?
-         (check-file-system source type))
-       (mkdir-p mount-point)
-       (mount source mount-point type (mount-flags->bit-mask flags)
-              (if options
-                  (string->pointer options)
-                  %null-pointer))
-
-       ;; Update /etc/mtab.
-       (mkdir-p (string-append root "/etc"))
-       (let ((port (open-file (string-append root "/etc/mtab") "a")))
-         (format port "~a ~a ~a ~a 0 0~%"
-                 source mount-point type (or options ""))
-         (close-port port))))))
-
 (define (switch-root root)
   "Switch to ROOT as the root file system, in a way similar to what
 util-linux' switch_root(8) does."

gnu/build/linux-initrd.scm

@@ -0,0 +1,72 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build linux-initrd)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 ftw)
+  #:export (write-cpio-archive))
+
+;;; Commentary:
+;;;
+;;; Tools to create Linux initial RAM disks ("initrds").  Initrds are
+;;; essentially gzipped cpio archives, with a '/init' executable that the
+;;; kernel runs at boot time.
+;;;
+;;; Code:
+
+(define* (write-cpio-archive output directory
+                             #:key
+                             (compress? #t)
+                             (cpio "cpio") (gzip "gzip"))
+  "Write a cpio archive containing DIRECTORY to file OUTPUT, using CPIO.  When
+COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
+
+  ;; Note: don't use '--no-absolute-filenames' since that strips leading
+  ;; slashes from symlink targets.
+  (let ((pipe (open-pipe* OPEN_WRITE cpio "-o" "-O" output
+                          "-H" "newc" "--null")))
+    (define (print0 file)
+      (format pipe "~a\0" file))
+
+    ;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries
+    ;; before the files that are inside of it: "The Linux kernel cpio
+    ;; extractor won't create files in a directory that doesn't exist, so the
+    ;; directory entries must go before the files that go in those
+    ;; directories."
+
+    ;; XXX: Use a deterministic order.
+    (file-system-fold (const #t)
+                      (lambda (file stat result)   ; leaf
+                        (print0 file))
+                      (lambda (dir stat result)    ; down
+                        (unless (string=? dir directory)
+                          (print0 dir)))
+                      (const #f)                   ; up
+                      (const #f)                   ; skip
+                      (const #f)
+                      #f
+                      directory)
+
+    (and (zero? (close-pipe pipe))
+         (or (not compress?)
+             (and (zero? (system* gzip "--best" output))
+                  (rename-file (string-append output ".gz")
+                               output))
+             output))))
+
+;;; linux-initrd.scm ends here

gnu/build/vm.scm

@@ -16,14 +16,13 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (guix build vm)
+(define-module (gnu build vm)
   #:use-module (guix build utils)
-  #:use-module (guix build linux-initrd)
-  #:use-module (guix build install)
+  #:use-module (guix build store-copy)
+  #:use-module (gnu build linux-boot)
+  #:use-module (gnu build install)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
-  #:use-module (ice-9 rdelim)
-  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (qemu-command
             load-in-linux-vm
@@ -111,20 +110,6 @@ the #:references-graphs parameter of 'derivation'."
         (mkdir output)
         (copy-recursively "xchg" output))))
 
-(define (read-reference-graph port)
-  "Return a list of store paths from the reference graph at PORT.
-The data at PORT is the format produced by #:references-graphs."
-  (let loop ((line   (read-line port))
-             (result '()))
-    (cond ((eof-object? line)
-           (delete-duplicates result))
-          ((string-prefix? "/" line)
-           (loop (read-line port)
-                 (cons line result)))
-          (else
-           (loop (read-line port)
-                 result)))))
-
 (define* (initialize-partition-table device partition-size
                                      #:key
                                      (label-type "msdos")
@@ -140,26 +125,6 @@ success."
                           (format #f "~aB" partition-size)))
     (error "failed to create partition table")))
 
-(define* (populate-store reference-graphs target)
-  "Populate the store under directory TARGET with the items specified in
-REFERENCE-GRAPHS, a list of reference-graph files."
-  (define store
-    (string-append target (%store-directory)))
-
-  (define (things-to-copy)
-    ;; Return the list of store files to copy to the image.
-    (define (graph-from-file file)
-      (call-with-input-file file read-reference-graph))
-
-    (delete-duplicates (append-map graph-from-file reference-graphs)))
-
-  (mkdir-p store)
-  (chmod store #o1775)
-  (for-each (lambda (thing)
-              (copy-recursively thing
-                                (string-append target thing)))
-            (things-to-copy)))
-
 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
 (define* (format-partition partition type

gnu/packages.scm

@@ -28,6 +28,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-39)
   #:export (search-patch
@@ -45,7 +46,9 @@
             package-transitive-dependents
             package-covering-dependents
 
-            check-package-freshness))
+            check-package-freshness
+
+            specification->package))
 
 ;;; Commentary:
 ;;;
@@ -326,3 +329,24 @@ but ~a is available upstream~%")
       (case key
         ((getaddrinfo-error ftp-error) #f)
         (else (apply throw key args))))))
+
+(define (specification->package spec)
+  "Return a package matching SPEC.  SPEC may be a package name, or a package
+name followed by a hyphen and a version number.  If the version number is not
+present, return the preferred newest version."
+  (let-values (((name version)
+                (package-name->name+version spec)))
+    (match (find-best-packages-by-name name version)
+      ((p)                                      ; one match
+       p)
+      ((p x ...)                                ; several matches
+       (warning (_ "ambiguous package specification `~a'~%") spec)
+       (warning (_ "choosing ~a from ~a~%")
+                (package-full-name p)
+                (location->string (package-location p)))
+       p)
+      (_                                        ; no matches
+       (if version
+           (leave (_ "~A: package not found for version ~a~%")
+                  name version)
+           (leave (_ "~A: unknown package~%") name))))))

gnu/packages/avahi.scm

@@ -68,3 +68,25 @@
 network.  It is an implementation of the mDNS (for \"Multicast DNS\") and
 DNS-SD (for \"DNS-Based Service Discovery\") protocols.")
     (license lgpl2.1+)))
+
+(define-public nss-mdns
+  (package
+    (name "nss-mdns")
+    (version "0.10")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append
+                    "http://0pointer.de/lennart/projects/nss-mdns/nss-mdns-"
+                    version ".tar.gz"))
+              (sha256
+               (base32
+                "0vgs6j0qsl0mwzh5a0m0bykr7x6bx79vnbyn0r3q289rghp3qs0y"))))
+    (build-system gnu-build-system)
+    (home-page "http://0pointer.de/lennart/projects/nss-mdns/")
+    (synopsis "The mDNS Name Service Switch (NSS) plug-in")
+    (description
+     "'nss-mdns' is a plug-in for the Name Service Switch (NSS) functionality
+of the GNU C Library, providing host name resolution via Multicast DNS (mDNS).
+It allows for name resolution by programs in the ad-hoc mDNS domain
+'.local'.")
+    (license lgpl2.1+)))

gnu/packages/commencement.scm

@@ -744,6 +744,10 @@ COREUTILS-FINAL vs. COREUTILS, etc."
                    (union-build (assoc-ref %outputs "debug")
                                 (list (assoc-ref %build-inputs
                                                  "libc-debug"))))))
+
+    (native-search-paths (package-native-search-paths gcc))
+    (search-paths (package-search-paths gcc))
+
     (license (package-license gcc))
     (synopsis "Complete GCC tool chain for C/C++ development")
     (description

gnu/packages/datamash.scm

@@ -27,7 +27,7 @@
 (define-public datamash
   (package
     (name "datamash")
-    (version "1.0.5")
+    (version "1.0.6")
     (source
      (origin
       (method url-fetch)
@@ -35,7 +35,7 @@
                           version ".tar.gz"))
       (sha256
        (base32
-        "0f4rbbhl18fb851npza9cl8biynzr081f37ih2xsbvjlyrxhnz6b"))))
+        "0621a1xyf8gvcks0vb26g72dm4zh1s6y3a4cc5nnnl5m8mfc4m01"))))
     (native-inputs
      `(("which" ,which)                 ;for tests
        ("perl" ,perl)))                 ;for help2man
@@ -45,4 +45,4 @@
     (description
      "Perform basic numeric, textual and statistical operations on plain text
 files.  Designed to work within standard pipelines without additional code.")
-    (license gpl3)))
+    (license gpl3+)))

gnu/packages/gnutls.scm

@@ -36,7 +36,7 @@
 (define-public libtasn1
   (package
     (name "libtasn1")
-    (version "3.6")
+    (version "4.1")
     (source
      (origin
       (method url-fetch)
@@ -44,7 +44,7 @@
                           version ".tar.gz"))
       (sha256
        (base32
-        "0c547qa1vfk1x2jzgjhf65izf4sfi86c6g46q7779g4aldk4gqqr"))))
+        "00gkyppzw6fqi5mnc3d8paf7bp6nfhi9213481awy07sviqnbvk0"))))
     (build-system gnu-build-system)
     (native-inputs `(("perl" ,perl)
 

gnu/packages/linux.scm

@@ -189,7 +189,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
      #f)))
 
 (define-public linux-libre
-  (let* ((version "3.16.1")
+  (let* ((version "3.16.2")
          (build-phase
           '(lambda* (#:key system inputs #:allow-other-keys #:rest args)
              ;; Apply the neat patch.
@@ -262,7 +262,7 @@ for SYSTEM, or #f if there is no configuration for SYSTEM."
              (uri (linux-libre-urls version))
              (sha256
               (base32
-               "1x4y0017l4ndcab4smky2wx0n86r3wyks2r8yyp19ia9ccnl98mf"))))
+               "1p08cqy6427yi808fpbwbb4zbwhnkibj2i1wbrfa5rjhd4vnnffz"))))
     (build-system gnu-build-system)
     (native-inputs `(("perl" ,perl)
                      ("bc" ,bc)
@@ -1092,7 +1092,16 @@ UnionFS-FUSE additionally supports copy-on-write.")
                                   libs " dl)"))))))
     (arguments
      '(#:tests? #f
-       #:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static")))
+       #:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static")
+       #:phases (alist-cons-after
+                 'install 'post-install
+                 (lambda* (#:key outputs #:allow-other-keys)
+                   (let* ((out (assoc-ref outputs "out"))
+                          (exe (string-append out "/bin/unionfs")))
+                     ;; By default, 'unionfs' keeps references to
+                     ;; $glibc/share/locale and similar stuff.  Remove them.
+                     (remove-store-references exe)))
+                 %standard-phases)))
     (inputs `(("fuse" ,fuse-static)))))
 
 (define-public sshfs-fuse

gnu/packages/man.scm

@@ -145,7 +145,7 @@ Linux kernel and C library interfaces employed by user-space programs.")
 (define-public help2man
   (package
     (name "help2man")
-    (version "1.45.1")
+    (version "1.46.1")
     (source
      (origin
       (method url-fetch)
@@ -153,7 +153,7 @@ Linux kernel and C library interfaces employed by user-space programs.")
                           version ".tar.xz"))
       (sha256
        (base32
-        "1hk7ciqinq7djdb7s94y3jxh06rp8i93bpjmg4r40cniws8wf3y7"))))
+        "0iqwb3qirl7rp1wwpbh01q89qxvi4h3bc73wi03av6hl4sh05z9x"))))
     (build-system gnu-build-system)
     (arguments `(;; There's no `check' target.
                  #:tests? #f))

gnu/packages/nvi.scm

@@ -0,0 +1,68 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Marek Benc <merkur32@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu packages nvi)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages bdb)
+  #:use-module (gnu packages ncurses)
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix licenses))
+
+(define-public nvi
+  (package
+    (name "nvi")
+    (version "1.81.6")
+    (source
+      (origin
+        (method url-fetch)
+        (uri          ;; sites.google.coma/bostic.com/keithbostic/vi is stale.
+          (string-append "http://harrier.slackbuilds.org/misc/nvi-" version
+                         ".tar.bz2"))
+        (sha256
+          (base32 "0nbbs1inyrqds0ywn3ln5slv54v5zraq7lszkg8nsavv4kivhh9l"))
+        (patches (list (search-patch "nvi-assume-preserve-path.patch")))
+        (snippet
+          ;; Create a wrapper for the configure script, make it executable.
+          '(let ((conf-wrap (open-output-file "configure")))
+             (display "#!/bin/sh" conf-wrap)
+             (newline conf-wrap)
+             (display
+               "../nvi-1.81.6/dist/configure --srcdir=../nvi-1.81.6/dist $@"
+               conf-wrap)
+             (newline conf-wrap)
+             (close-output-port conf-wrap)
+             (chmod "configure" #o0755)))))
+
+    (build-system gnu-build-system)
+    (arguments
+      `(#:out-of-source? #t))
+    (inputs
+      `(("bdb" ,bdb)
+        ("ncurses" ,ncurses)))
+    (synopsis "The Berkeley Vi Editor")
+    (description
+      "Vi is the original screen based text editor for Unix systems.  It is
+considered the standard text editor, and is available on almost all Unix
+systems.  Nvi is intended as a \"bug-for-bug compatible\" clone of the original
+BSD vi editor.  As such, it doesn't have a lot of snazzy features as do some
+of the other vi clones such as elvis and vim.  However, if all you want is vi,
+this is the one to get.")
+    (home-page "https://sites.google.com/a/bostic.com/keithbostic/vi")
+    (license bsd-3)))

gnu/packages/parallel.scm

@@ -27,7 +27,7 @@
 (define-public parallel
   (package
     (name "parallel")
-    (version "20140722")
+    (version "20140822")
     (source
      (origin
       (method url-fetch)
@@ -35,7 +35,7 @@
                           version ".tar.bz2"))
       (sha256
        (base32
-        "165vf8hpl47z38aswsll1284l8xa9a8jwx3a3d2rzshm9yzbiq5n"))))
+        "1m3z77fnc2bfissq642p44xgw1jyp00wiwk1slhqj8bipicnl54a"))))
     (build-system gnu-build-system)
     (inputs `(("perl" ,perl)))
     (home-page "http://www.gnu.org/software/parallel/")

gnu/packages/patches/nvi-assume-preserve-path.patch

@@ -0,0 +1,30 @@
+Make configure assume nvi can store backups in /var/tmp.
+
+--- a/dist/configure	2014-09-01 14:46:01.075778095 +0200
++++ b/dist/configure	2014-09-01 14:52:08.411790122 +0200
+@@ -21319,23 +21319,8 @@
+ if test "${vi_cv_path_preserve+set}" = set; then
+   echo $ECHO_N "(cached) $ECHO_C" >&6
+ else
+-  	dirlist="/var/preserve /var/tmp /usr/tmp"
+-	vi_cv_path_preserve=no
+-	for i in $dirlist; do
+-		if test -d $i/vi.recover; then
+-			vi_cv_path_preserve=$i/vi.recover
+-			break;
+-		fi
+-	done
+-	if test "$vi_cv_path_preserve" = no; then
+-		for i in $dirlist; do
+-			if test -d $i -a -w $i; then
+-				vi_cv_path_preserve=$i/vi.recover
+-				break;
+-			fi
+-		done
+-
+-	fi
++#	Assume /var/tmp
++	vi_cv_path_preserve=/var/tmp/vi.recover
+ fi
+ 
+ if test "$vi_cv_path_preserve" = no; then

gnu/packages/postgresql.scm

@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu packages postgresql)
+  #:use-module ((guix licenses) #:select (x11-style))
+  #:use-module (guix packages)
+  #:use-module (guix download)
+  #:use-module (guix build-system gnu)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages compression)
+  #:use-module (gnu packages readline))
+
+(define-public postgresql
+  (package
+   (name "postgresql")
+   (version "9.3.5")
+   (source (origin
+            (method url-fetch)
+            (uri (string-append "http://ftp.postgresql.org/pub/source/v"
+                                version "/postgresql-" version ".tar.gz"))
+            (sha256
+             (base32
+              "08kga00izykgvnx7hn995wc4zjqslspapaa8z63045p1ya14mr4g"))))
+   (build-system gnu-build-system)
+   (inputs
+    `(("readline" ,readline)
+      ("zlib" ,zlib)))
+   (home-page "http://www.postgresql.org/")
+   (synopsis "Powerful object-relational database system")
+   (description
+    "PostgreSQL is a powerful object-relational database system.  It is fully
+ACID compliant, has full support for foreign keys, joins, views, triggers, and
+stored procedures (in multiple languages).  It includes most SQL:2008 data
+types, including INTEGER, NUMERIC, BOOLEAN, CHAR, VARCHAR, DATE, INTERVAL, and
+TIMESTAMP.  It also supports storage of binary large objects, including
+pictures, sounds, or video.")
+   (license (x11-style "file://COPYRIGHT"))))

gnu/packages/python.scm

@@ -22,8 +22,8 @@
 
 (define-module (gnu packages python)
   #:use-module ((guix licenses)
-                #:select (asl2.0 bsd-3 bsd-style cc0 expat x11 x11-style
-                          gpl2 gpl2+ lgpl2.1+
+                #:select (asl2.0 bsd-3 bsd-2 bsd-style cc0 expat x11 x11-style
+                          gpl2 gpl2+ gpl3+ lgpl2.0+ lgpl2.1+
                           psfl public-domain))
   #:use-module ((guix licenses) #:select (zlib)
                                 #:renamer (symbol-prefix-proc 'license:))
@@ -939,6 +939,448 @@ In short, SCons is an easier, more reliable and faster way to build
 software.")
     (license x11)))
 
+(define-public python-extras
+  (package
+    (name "python-extras")
+    (version "0.0.3")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/e/extras/extras-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1h7zx4dfyclalg0fqnfjijpn0f793a9mx8sy3b27gd31nr6dhq3s"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments
+     ;; error in setup.cfg: command 'test' has no such option 'buffer'
+     '(#:tests? #f))
+    (home-page "https://github.com/testing-cabal/extras")
+    (synopsis "Useful extensions to the Python standard library")
+    (description
+     "Extras is a set of extensions to the Python standard library.")
+    (license expat)))
+
+(define-public python2-extras
+  (package-with-python2 python-extras))
+
+(define-public python-mimeparse
+  (package
+    (name "python-mimeparse")
+    (version "0.1.4")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/p/python-mimeparse/python-mimeparse-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1hyxg09kaj02ri0rmwjqi86wk4nd1akvv7n0dx77azz76wga4s9w"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments
+     '(#:tests? #f)) ; no setup.py test command
+    (home-page
+     "https://github.com/dbtsai/python-mimeparse")
+    (synopsis "Python library for parsing MIME types.")
+    (description
+     "Mimeparse provides basic functions for parsing MIME type names and
+matching them against a list of media-ranges.")
+    (license expat)))
+
+(define-public python2-mimeparse
+  (package-with-python2 python-mimeparse))
+
+(define-public python-nose
+  (package
+    (name "python-nose")
+    (version "1.3.4")
+    (source
+      (origin
+        (method url-fetch)
+        (uri (string-append
+               "https://pypi.python.org/packages/source/n/nose/nose-"
+               version ".tar.gz"))
+        (sha256
+          (base32
+            "00qymfgwg4iam4xi0w9bnv7lcb3fypq1hzfafzgs1rfmwaj67g3n"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments
+     '(#:tests? #f)) ; FIXME: test suite fails
+    (home-page "http://readthedocs.org/docs/nose/")
+    (synopsis "Python testing library")
+    (description
+     "Nose extends the unittest library to make testing easier.")
+    (license lgpl2.0+)))
+
+(define-public python2-nose
+  (package-with-python2 python-nose))
+
+(define-public python-unittest2
+  (package
+    (name "python-unittest2")
+    (version "0.5.1")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/u/unittest2py3k/unittest2py3k-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "00yl6lskygcrddx5zspkhr0ibgvpknl4678kkm6s626539grq93q"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://pypi.python.org/pypi/unittest2")
+    (synopsis "Python unit testing library")
+    (description
+     "Unittest2 is a replacement for the unittest module in the Python
+standard library.")
+    (license psfl)))
+
+(define-public python2-unittest2
+  (package (inherit python-unittest2)
+    (name "python2-unittest2")
+    (version "0.5.1")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/u/unittest2/unittest2-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0wbs4i4x3x7klr3v35ss6p9mcqz883i1xgcpkhvl7n2lyv6yhpda"))))
+    (inputs
+     `(("python2-setuptools" ,python-setuptools)))
+    (arguments
+     `(#:python ,python-2
+       #:tests? #f)))) ; no setup.py test command
+
+(define-public python-py
+  (package
+    (name "python-py")
+    (version "1.4.23")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/p/py/py-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1jkhffpai419v5rickm2vz86p9bkg3b3kcm2k4bi5wfajhw2m3xs"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://pylib.readthedocs.org/")
+    (synopsis "Python library for parsing, I/O, instrospection, and logging")
+    (description
+     "Py is a Python library for file name parsing, .ini file parsing, I/O,
+code introspection, and logging.")
+    (license expat)))
+
+(define-public python2-py
+  (package-with-python2 python-py))
+
+(define-public python-pytest
+  (package
+    (name "python-pytest")
+    (version "2.6.1")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/p/pytest/pytest-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0g2w4p0n42wvz8rq4k6gnzpkakgz3g8sfanxk8jrsra9675snkcr"))
+       (modules '((guix build utils)))
+       (snippet
+        ;; One of the tests involves the /usr directory, so it fails.
+        '(substitute* "testing/test_argcomplete.py"
+           (("def test_remove_dir_prefix\\(self\\):")
+            "@pytest.mark.xfail\n    def test_remove_dir_prefix(self):")))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-py" ,python-py)
+       ("python-nose" ,python-nose)
+       ("python-mock" ,python-mock)))
+    (home-page "http://pytest.org")
+    (synopsis "Python testing library")
+    (description
+     "Pytest is a testing tool that provides auto-discovery of test modules
+and functions, detailed info on failing assert statements, modular fixtures,
+and many external plugins.")
+    (license expat)))
+
+(define-public python2-pytest
+  (package-with-python2 python-pytest))
+
+(define-public python-scripttest
+  (package
+    (name "python-scripttest")
+    (version "1.3")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/s/scripttest/scripttest-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0f4w84k8ck82syys7yg9maz93mqzc8p5ymis941x034v44jzq74m"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-pytest" ,python-pytest)))
+    (home-page "http://pythonpaste.org/scripttest/")
+    (synopsis "Python library to test command-line scripts")
+    (description "Scripttest is a Python helper library for testing
+interactive command-line applications.  With it you can run a script in a
+subprocess and see the output as well as any file modifications.")
+    (license expat)))
+
+(define-public python2-scripttest
+  (package-with-python2 python-scripttest))
+
+(define-public python-testtools
+  (package
+    (name "python-testtools")
+    (version "1.0.0")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/t/testtools/testtools-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1dyml28ykpl5jb9khdmcdvhy1cxqingys6qvj2k04fzlaj6z3bbx"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-mimeparse" ,python-mimeparse)
+       ("python-extras" ,python-extras)))
+    (home-page "https://github.com/testing-cabal/testtools")
+    (synopsis
+     "Extensions to the Python standard library unit testing framework")
+    (description
+     "Testtools extends the Python standard library unit testing framework to
+provide matchers, more debugging information, and cross-Python
+compatibility.")
+    (license psfl)))
+
+(define-public python2-testtools
+  (package-with-python2 python-testtools))
+
+(define-public python-testscenarios
+  (package
+    (name "python-testscenarios")
+    (version "0.4")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/t/testscenarios/testscenarios-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1671jvrvqlmbnc42j7pc5y6vc37q44aiwrq0zic652pxyy2fxvjg"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-testtools" ,python-testtools)
+       ("python-mimeparse" ,python-mimeparse)))
+    (home-page "https://launchpad.net/testscenarios")
+    (synopsis "Pyunit extension for dependency injection")
+    (description
+     "Testscenarios provides clean dependency injection for Python unittest
+style tests.")
+    (license (list bsd-3 asl2.0)))) ; at the user's option
+
+(define-public python2-testscenarios
+  (package-with-python2 python-testscenarios))
+
+(define-public python-testresources
+  (package
+    (name "python-testresources")
+    (version "0.2.7")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/t/testresources/testresources-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0cbj3plbllyz42c4b5xxgwaa7mml54lakslrn4kkhinxhdri22md"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "https://launchpad.net/testresources")
+    (synopsis
+     "Pyunit extension for managing test resources")
+    (description
+     "Testresources is an extension to Python's unittest to allow declarative
+use of resources by test cases.")
+    (license (list bsd-3 asl2.0)))) ; at the user's option
+
+(define-public python2-testresources
+  (package-with-python2 python-testresources))
+
+(define-public python-subunit
+  (package
+    (name "python-subunit")
+    (version "0.0.21")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/p/python-subunit/python-subunit-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1nkw9wfbvizmpajbj3in8ns07g7lwkiv8hip14jjlwk3cacls6jv"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-testtools" ,python-testtools)
+       ("python-mimeparse" ,python-mimeparse)
+       ("python-testscenarios" ,python-testscenarios)))
+    (home-page "http://launchpad.net/subunit")
+    (synopsis "Python implementation of the subunit protocol")
+    (description
+     "Python-subunit is a Python implementation of the subunit test streaming
+protocol.")
+    (license (list bsd-3 asl2.0)))) ; at the user's option
+
+(define-public python2-subunit
+  (package-with-python2 python-subunit))
+
+(define-public python-fixtures
+  (package
+    (name "python-fixtures")
+    (version "0.3.16")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/f/fixtures/fixtures-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0x9r2gwilcig5g54k60bxzg96zabizq1855lrprlb4zckalp9asc"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments
+     '(#:tests? #f)) ; no setup.py test command
+    (home-page "https://launchpad.net/python-fixtures")
+    (synopsis "Python test fixture library")
+    (description
+     "Fixtures provides a way to create reusable state, useful when writing
+Python tests.")
+    (license (list bsd-3 asl2.0)))) ; at user's option
+
+(define-public python2-fixtures
+  (package-with-python2 python-fixtures))
+
+(define-public python-testrepository
+  (package
+    (name "python-testrepository")
+    (version "0.0.20")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/t/testrepository/testrepository-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1ssqb07c277010i6gzzkbdd46gd9mrj0bi0i8vn560n2k2y4j93m"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-testtools" ,python-testtools)
+       ("python-subunit" ,python-subunit)
+       ("python-fixtures" ,python-fixtures)
+       ("python-mimeparse" ,python-mimeparse)))
+    (home-page "https://launchpad.net/testrepository")
+    (synopsis "Database for Python test results")
+    (description "Testrepository provides a database of test results which can
+be used as part of a developer's workflow to check things such as what tests
+have failed since the last commit or what tests are currently failing.")
+    (license (list bsd-3 asl2.0)))) ; at user's option
+
+(define-public python2-testrepository
+  (package-with-python2 python-testrepository))
+
+(define-public python-coverage
+  (package
+    (name "python-coverage")
+    (version "3.7.1")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/c/coverage/coverage-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0knlbq79g2ww6xzsyknj9rirrgrgc983dpa2d9nkdf31mb2a3bni"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://nedbatchelder.com/code/coverage")
+    (synopsis "Code coverage measurement for Python")
+    (description
+     "Coverage measures code coverage, typically during test execution.  It
+uses the code analysis tools and tracing hooks provided in the Python standard
+library to determine which lines are executable, and which have been
+executed.")
+    (license bsd-3)))
+
+(define-public python2-coverage
+  (package-with-python2 python-coverage))
+
+(define-public python-discover
+  (package
+    (name "python-discover")
+    (version "0.4.0")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/d/discover/discover-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "0y8d0zwiqar51kxj8lzmkvwc3b8kazb04gk5zcb4nzg5k68zmhq5"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://pypi.python.org/pypi/discover/")
+    (synopsis
+     "Python test discovery for unittest")
+    (description
+     "Discover provides test discovery for unittest, a feature that has been
+backported from Python 2.7 for Python 2.4+")
+    (license bsd-3)))
+
+(define-public python2-discover
+  (package-with-python2 python-discover))
+
 (define-public behave
   (package
     (name "behave")
@@ -968,3 +1410,427 @@ technique that encourages collaboration between developers, QA and
 non-technical or business participants in a software project.  Behave uses
 tests written in a natural language style, backed up by Python code.")
     (license x11)))
+
+(define-public python-exif-read
+  (package
+    (name "python-exif-read")
+    (version "1.4.2")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append
+                "https://pypi.python.org/packages/source/E/ExifRead/ExifRead-"
+                version ".tar.gz"))
+              (sha256
+               (base32
+                "17c627gcdmyc05hz4zk8qs4pjgw6rc68qzjzgz8gh1cmpsd7acf1"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments `(#:tests? #f)) ; no tests
+    (home-page "https://github.com/ianare/exif-py")
+    (synopsis "Python library to extract EXIF data from image files")
+    (description
+     "ExifRead is a Python library to extract EXIF data from tiff and jpeg
+files.")
+    (license bsd-3)))
+
+(define-public python2-exif-read
+  (package-with-python2 python-exif-read))
+
+(define-public python-pyld
+  (package
+    (name "python-pyld")
+    (version "0.6.0")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append
+                "https://pypi.python.org/packages/source/P/PyLD/PyLD-"
+                version ".tar.gz"))
+              (sha256
+               (base32
+                "1l9ymj85fsvayqplinzpk0kyiq6m74ps9xd3a9fhlxfn1rldf8x8"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments `(#:tests? #f)) ; no tests
+    (home-page "http://github.com/digitalbazaar/pyld")
+    (synopsis "Python implementation of the JSON-LD specification")
+    (description
+     "PyLD is an implementation of the JSON-LD specification.")
+    (license bsd-3)))
+
+(define-public python2-pyld
+  (package-with-python2 python-pyld))
+
+(define-public python-certifi
+  (package
+    (name "python-certifi")
+    (version "14.05.14")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append
+                "https://pypi.python.org/packages/source/c/certifi/certifi-"
+                version ".tar.gz"))
+              (sha256
+               (base32
+                "0s8vxzfz6s4m6fvxc7z25k9j35w0rh6jkw3wwcd1az1mssncn6qy"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments `(#:tests? #f)) ; no tests
+    (home-page "http://python-requests.org/")
+    (synopsis "Python CA certificate bundle")
+    (description
+     "Certifi is a Python library that contains a CA certificate bundle, which
+is used by the Requests library to verify HTTPS requests.")
+    (license asl2.0)))
+
+(define-public python2-certifi
+  (package-with-python2 python-certifi))
+
+(define-public python2-requests
+  (package
+    (name "python2-requests")
+    (version "2.4.0")
+    (source (origin
+             (method url-fetch)
+             (uri
+              (string-append
+               "https://pypi.python.org/packages/source/r/requests/requests-"
+               version ".tar.gz"))
+             (sha256
+              (base32
+               "0gknlfx1wakrrm1zi8gi03x2lzj4dsns0vjw0nsmgqvkphyf01vh"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-certifi" ,python-certifi)))
+    (arguments `(#:tests? #f ; no tests
+                 #:python ,python-2))
+    (home-page "http://python-requests.org/")
+    (synopsis "Python HTTP library")
+    (description
+     "Requests is a Python HTTP client library.  It aims to be easier to use
+than Python’s urllib2 library.")
+    (license asl2.0)))
+
+(define-public python-jsonschema
+  (package
+    (name "python-jsonschema")
+    (version "2.4.0")
+    (source (origin
+             (method url-fetch)
+             (uri
+              (string-append
+               "https://pypi.python.org/packages/source/j/jsonschema/jsonschema-"
+               version ".tar.gz"))
+             (sha256
+              (base32
+               "1yik3031ziygvq66rj3mzfqdgxj29sg1bkfc46wsgi7lnbqs560j"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://github.com/Julian/jsonschema")
+    (synopsis "Implementation of JSON Schema for Python")
+    (description
+     "Jsonschema is an implementation of JSON Schema for Python.")
+    (license expat)))
+
+(define-public python2-jsonschema
+  (package-with-python2 python-jsonschema))
+
+(define-public python-unidecode
+  (package
+    (name "python-unidecode")
+    (version "0.04.16")
+    (source (origin
+             (method url-fetch)
+             (uri
+              (string-append
+               "https://pypi.python.org/packages/source/U/Unidecode/Unidecode-"
+               version ".tar.gz"))
+             (sha256
+              (base32
+               "0yv56vc49rvippyxgxvcyz7jklc07ky38rcspax7p00sgmriiljc"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "https://pypi.python.org/pypi/Unidecode")
+    (synopsis "ASCII transliterations of Unicode text")
+    (description
+     "Unidecode provides ASCII transliterations of Unicode text.  Unidecode is
+useful when integrating with legacy code that doesn't support Unicode, or for
+ease of entry of non-Roman names on a US keyboard, or when constructing ASCII
+machine identifiers from human-readable Unicode strings that should still be
+somewhat intelligeble.")
+    (license gpl2+)))
+
+(define-public python2-unidecode
+  (package-with-python2 python-unidecode))
+
+(define-public python-pyjwt
+  (package
+    (name "python-pyjwt")
+    (version "0.2.1")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/P/PyJWT/PyJWT-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1ahqblfy2sj3xz34wsa48cn9rp0dspzq56p54i5znmws3b8gml6g"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments
+     '(#:tests? #f)) ; test suite doesn't work
+    (home-page "http://github.com/progrium/pyjwt")
+    (synopsis "JSON Web Token implementation in Python")
+    (description
+     "PyJWT is a JSON Web Token implementation written in Python.")
+    (license expat)))
+
+(define-public python2-pyjwt
+  (package-with-python2 python-pyjwt))
+
+(define-public python-oauthlib
+  (package
+    (name "python-oauthlib")
+    (version "0.6.3")
+    (source (origin
+              (method url-fetch)
+              (uri
+               (string-append
+                "https://pypi.python.org/packages/source/o/oauthlib/oauthlib-"
+                version ".tar.gz"))
+              (sha256
+               (base32
+                "1yaj3j64la4arwsbhbfmpnickzh3jpg9nlpyg409v8pp24isn48a"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-pyjwt" ,python-pyjwt)
+       ("python-pycrypto" ,python-pycrypto)
+       ("python-nose" ,python-nose)
+       ("python-mock" ,python-mock)))
+    (home-page "https://github.com/idan/oauthlib")
+    (synopsis "OAuth implementation for Python")
+    (description
+     "Oauthlib is a generic, spec-compliant, thorough implementation of the
+OAuth request-signing logic.")
+    (license bsd-3)))
+
+(define-public python2-oauthlib
+  (let ((base (package-with-python2 python-oauthlib)))
+    (package
+      (inherit base)
+      (name "python2-oauthlib")
+      (version "0.6.3")
+      (source (origin
+                (method url-fetch)
+                (uri
+                 (string-append
+                  "https://pypi.python.org/packages/source/o/oauthlib/oauthlib-"
+                  version ".tar.gz"))
+                (sha256
+                 (base32
+                  "1yaj3j64la4arwsbhbfmpnickzh3jpg9nlpyg409v8pp24isn48a"))))
+      (inputs
+       (append (package-inputs base)
+               `(("python2-unittest2" ,python2-unittest2)))))))
+
+(define-public python-itsdangerous
+  (package
+    (name "python-itsdangerous")
+    (version "0.24")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/i/itsdangerous/itsdangerous-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "06856q6x675ly542ig0plbqcyab6ksfzijlyf1hzhgg3sgwgrcyb"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://github.com/mitsuhiko/itsdangerous")
+    (synopsis "Python library for passing data to/from untrusted environments")
+    (description
+     "Itsdangerous provides various helpers to pass trusted data to untrusted
+environments and back.")
+    (license bsd-3)))
+
+(define-public python2-itsdangerous
+  (package-with-python2 python-itsdangerous))
+
+(define-public python-virtualenv
+  (package
+    (name "python-virtualenv")
+    (version "1.11.6")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/v/virtualenv/virtualenv-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1xq4prmg25n9cz5zcvbqx68lmc3kl39by582vd8pzs9f3qalqyiy"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-mock" ,python-mock)
+       ("python-nose" ,python-nose)))
+    (home-page "https://virtualenv.pypa.io/")
+    (synopsis "Virtual Python environment builder")
+    (description
+     "Virtualenv is a tool to create isolated Python environments.")
+    (license expat)))
+
+(define-public python2-virtualenv
+  (package-with-python2 python-virtualenv))
+
+(define-public python-markupsafe
+  (package
+    (name "python-markupsafe")
+    (version "0.23")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/M/MarkupSafe/MarkupSafe-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1hvip33wva3fnmvfp9x5klqri7hpl1hkgqmjbss18nmrb7zimv54"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://github.com/mitsuhiko/markupsafe")
+    (synopsis "XML/HTML/XHTML markup safe string implementation for Python")
+    (description
+     "Markupsafe provides an XML/HTML/XHTML markup safe string implementation
+for Python.")
+    (license bsd-3)))
+
+(define-public python2-markupsafe
+  (package-with-python2 python-markupsafe))
+
+(define-public python-jinja2
+  (package
+    (name "python-jinja2")
+    (version "2.7.3")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/J/Jinja2/Jinja2-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1nwg9yfqgy421lncnm63k1zf9xkd1klc0jm0fr4p3dad01fsq91f"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-markupsafe" ,python-markupsafe)))
+    (home-page "http://jinja.pocoo.org/")
+    (synopsis "Python template engine")
+    (description
+     "Jinja2 is a small but fast and easy to use stand-alone template engine
+written in pure Python.")
+    (license bsd-3)))
+
+(define-public python2-jinja2
+  (package-with-python2 python-jinja2))
+
+(define-public python-docutils
+  (package
+    (name "python-docutils")
+    (version "0.12")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/d/docutils/docutils-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1ylnjnw1x4b2y7blr6x35ncdzn69k253kw4cdkv6asdb21w73ny7"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (arguments
+     '(#:tests? #f)) ; no setup.py test command
+    (home-page "http://docutils.sourceforge.net/")
+    (synopsis "Python Documentation Utilities")
+    (description
+     "Docutils is a modular system for processing documentation into useful
+formats, such as HTML, XML, and LaTeX.  For input Docutils supports
+reStructuredText.")
+    ;; Most of the source code is public domain, but some source files are
+    ;; licensed under the PFSL, BSD 2-clause, and GPLv3+ licenses.
+    (license (list public-domain psfl bsd-2 gpl3+))))
+
+(define-public python2-docutils
+  (package-with-python2 python-docutils))
+
+(define-public python-pygments
+  (package
+    (name "python-pygments")
+    (version "1.6")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/P/Pygments/Pygments-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "1h11r6ss8waih51vcksfvzghfxiav2f8svc0812fa5kmyz5d97kr"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)))
+    (home-page "http://pygments.org/")
+    (synopsis "Syntax highlighting")
+    (description
+     "Pygments is a syntax highlighting package written in Python.")
+    (license bsd-2)))
+
+(define-public python2-pygments
+  (package-with-python2 python-pygments))
+
+(define-public python-sphinx
+  (package
+    (name "python-sphinx")
+    (version "1.2.3")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append
+             "https://pypi.python.org/packages/source/S/Sphinx/Sphinx-"
+             version ".tar.gz"))
+       (sha256
+        (base32
+         "011xizm3jnmf4cvs5i6kgf6c5nn046h79i8j0vd0f27yw9j3p4wl"))))
+    (build-system python-build-system)
+    (inputs
+     `(("python-setuptools" ,python-setuptools)
+       ("python-jinja2" ,python-jinja2)
+       ("python-docutils" ,python-docutils)
+       ("python-pygments" ,python-pygments)))
+    (home-page "http://sphinx-doc.org/")
+    (synopsis "Python documentation generator")
+    (description "Sphinx is a tool that makes it easy to create documentation
+for Python projects or other documents consisting of multiple reStructuredText
+sources.")
+    (license bsd-3)))
+
+(define-public python2-sphinx
+  (package-with-python2 python-sphinx))

gnu/packages/telephony.scm

@@ -56,13 +56,13 @@ reimplementation.")
 (define-public ucommon
   (package
    (name "ucommon")
-   (version "6.1.8")
+   (version "6.1.10")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnu/commoncpp/" name "-"
                    version ".tar.gz"))
             (sha256 (base32
-                     "1ibz5snb2gq0psw8z152qcbd1zaijpsksc3lrp6av60inyq3waws"))))
+                     "14myyz4vdq1hzp39k835lk1c9pr4pkhzapsxv50qnh9w3v9mx8fp"))))
    (build-system gnu-build-system)
    (synopsis "(u)Common C++ framework for threaded applications")
    (description "GNU Common C++ is an portable, optimized class framework for

gnu/services/base.scm

@@ -29,7 +29,7 @@
   #:use-module ((gnu packages base)
                 #:select (canonical-package glibc))
   #:use-module (gnu packages package-management)
-  #:use-module ((guix build linux-initrd)
+  #:use-module ((gnu build file-systems)
                 #:select (mount-flags->bit-mask))
   #:use-module (guix gexp)
   #:use-module (guix monads)

gnu/services/dmd.scm

@@ -35,7 +35,7 @@
   (define modules
     ;; Extra modules visible to dmd.conf.
     '((guix build syscalls)
-      (guix build linux-initrd)
+      (gnu build file-systems)
       (guix build utils)))
 
   (mlet %store-monad ((modules  (imported-modules modules))
@@ -50,7 +50,7 @@
           (use-modules (ice-9 ftw)
                        (guix build syscalls)
                        (guix build utils)
-                       ((guix build linux-initrd)
+                       ((gnu build file-systems)
                         #:select (check-file-system canonicalize-device-spec)))
 
           (register-services

gnu/system.scm

@@ -362,9 +362,10 @@ alias ll='ls -l'
 stateful part of OS, including user accounts and groups, special directories,
 etc."
   (define %modules
-    '((guix build activation)
-      (guix build utils)
-      (guix build linux-initrd)))
+    '((gnu build activation)
+      (gnu build linux-boot)
+      (gnu build file-systems)
+      (guix build utils)))
 
   (define (service-activations services)
     ;; Return the activation scripts for SERVICES.
@@ -399,7 +400,7 @@ etc."
                       (set! %load-compiled-path
                             (cons #$compiled %load-compiled-path)))
 
-                    (use-modules (guix build activation))
+                    (use-modules (gnu build activation))
 
                     ;; Populate /etc.
                     (activate-etc #$etc)

gnu/system/linux-initrd.scm

@@ -68,16 +68,22 @@ initrd."
   ;; General Linux overview in `Documentation/early-userspace/README' and
   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
 
-  (define (string->regexp str)
-    ;; Return a regexp that matches STR exactly.
-    (string-append "^" (regexp-quote str) "$"))
+  (define graph-files
+    (unfold-right zero?
+                  number->string
+                  1-
+                  (length to-copy)))
 
-  (mlet* %store-monad ((source   (imported-modules modules))
-                       (compiled (compiled-modules modules)))
+  (mlet %store-monad ((source     (imported-modules modules))
+                      (compiled   (compiled-modules modules))
+                      (module-dir (flat-linux-module-directory linux
+                                                               linux-modules)))
     (define builder
-      ;; TODO: Move most of this code to (guix build linux-initrd).
+      ;; TODO: Move most of this code to (gnu build linux-initrd).
       #~(begin
-          (use-modules (guix build utils)
+          (use-modules (gnu build linux-initrd)
+                       (guix build utils)
+                       (guix build store-copy)
                        (ice-9 pretty-print)
                        (ice-9 popen)
                        (ice-9 match)
@@ -87,9 +93,7 @@ initrd."
                        (rnrs bytevectors)
                        ((system foreign) #:select (sizeof)))
 
-          (let ((cpio    (string-append #$cpio "/bin/cpio"))
-                (gzip    (string-append #$gzip "/bin/gzip"))
-                (modules #$source)
+          (let ((modules #$source)
                 (gos     #$compiled)
                 (scm-dir (string-append "share/guile/" (effective-version)))
                 (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
@@ -101,6 +105,7 @@ initrd."
                                  (effective-version))))
             (mkdir #$output)
             (mkdir "contents")
+
             (with-directory-excursion "contents"
               (copy-recursively #$guile ".")
               (call-with-output-file "init"
@@ -127,74 +132,58 @@ initrd."
                             #:output-file (string-append go-dir "/init.go"))
 
               ;; Copy Linux modules.
-              (let* ((linux      #$linux)
-                     (module-dir (and linux
-                                      (string-append linux "/lib/modules"))))
-                (mkdir "modules")
-                #$@(map (lambda (module)
-                          #~(match (find-files module-dir
-                                               #$(string->regexp module))
-                              ((file)
-                               (format #t "copying '~a'...~%" file)
-                               (copy-file file (string-append "modules/"
-                                                              #$module)))
-                              (()
-                               (error "module not found" #$module module-dir))
-                              ((_ ...)
-                               (error "several modules by that name"
-                                      #$module module-dir))))
-                        linux-modules))
+              (mkdir "modules")
+              (copy-recursively #$module-dir "modules")
 
-              (let ((store   #$(string-append "." (%store-prefix)))
-                    (to-copy '#$to-copy))
-                (unless (null? to-copy)
-                  (mkdir-p store))
-                ;; XXX: Should we do export-references-graph?
-                (for-each (lambda (input)
-                            (let ((target
-                                   (string-append store "/"
-                                                  (basename input))))
-                              (copy-recursively input target)))
-                          to-copy))
+              ;; Populate the initrd's store.
+              (with-directory-excursion ".."
+                (populate-store '#$graph-files "contents"))
 
               ;; Reset the timestamps of all the files that will make it in the
               ;; initrd.
               (for-each (cut utime <> 0 0 0 0)
                         (find-files "." ".*"))
 
-              (system* cpio "--version")
-              (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
-                                      "-O" (string-append #$output "/initrd")
-                                      "-H" "newc" "--null")))
-                (define print0
-                  (let ((len (string-length "./")))
-                    (lambda (file)
-                      (format pipe "~a\0" (string-drop file len)))))
-
-                ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
-                ;; directory entries before the files that are inside of it: "The
-                ;; Linux kernel cpio extractor won't create files in a directory
-                ;; that doesn't exist, so the directory entries must go before
-                ;; the files that go in those directories."
-                (file-system-fold (const #t)
-                                  (lambda (file stat result) ; leaf
-                                    (print0 file))
-                                  (lambda (dir stat result) ; down
-                                    (unless (string=? dir ".")
-                                      (print0 dir)))
-                                  (const #f)         ; up
-                                  (const #f)         ; skip
-                                  (const #f)
-                                  #f
-                                  ".")
-
-                (and (zero? (close-pipe pipe))
-                     (with-directory-excursion #$output
-                       (and (zero? (system* gzip "--best" "initrd"))
-                            (rename-file "initrd.gz" "initrd")))))))))
+              (write-cpio-archive (string-append #$output "/initrd") "."
+                                  #:cpio (string-append #$cpio "/bin/cpio")
+                                  #:gzip (string-append #$gzip "/bin/gzip"))))))
 
    (gexp->derivation name builder
-                     #:modules '((guix build utils)))))
+                     #:modules '((guix build utils)
+                                 (guix build store-copy)
+                                 (gnu build linux-initrd))
+                     #:references-graphs (zip graph-files to-copy))))
+
+(define (flat-linux-module-directory linux modules)
+  "Return a flat directory containing the Linux kernel modules listed in
+MODULES and taken from LINUX."
+  (define build-exp
+    #~(begin
+        (use-modules (ice-9 match) (ice-9 regex)
+                     (guix build utils))
+
+        (define (string->regexp str)
+          ;; Return a regexp that matches STR exactly.
+          (string-append "^" (regexp-quote str) "$"))
+
+        (define module-dir
+          (string-append #$linux "/lib/modules"))
+
+        (mkdir #$output)
+        (for-each (lambda (module)
+                    (match (find-files module-dir (string->regexp module))
+                      ((file)
+                       (format #t "copying '~a'...~%" file)
+                       (copy-file file (string-append #$output "/" module)))
+                      (()
+                       (error "module not found" module module-dir))
+                      ((_ ...)
+                       (error "several modules by that name"
+                              module module-dir))))
+                  '#$modules)))
+
+  (gexp->derivation "linux-modules" build-exp
+                    #:modules '((guix build utils))))
 
 (define (file-system->spec fs)
   "Return a list corresponding to file-system FS that can be passed to the
@@ -277,7 +266,7 @@ exception and backtrace!)."
 
   (expression->initrd
    #~(begin
-       (use-modules (guix build linux-initrd)
+       (use-modules (gnu build linux-boot)
                     (guix build utils)
                     (srfi srfi-26))
 
@@ -293,7 +282,8 @@ exception and backtrace!)."
                     #:volatile-root? '#$volatile-root?))
    #:name "base-initrd"
    #:modules '((guix build utils)
-               (guix build linux-initrd))
+               (gnu build linux-boot)
+               (gnu build file-systems))
    #:to-copy helper-packages
    #:linux linux-libre
    #:linux-modules linux-modules))

gnu/system/vm.scm

@@ -23,7 +23,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix monads)
-  #:use-module ((guix build vm)
+  #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
   #:use-module (gnu packages guile)
@@ -112,10 +112,12 @@ input tuple.  The output file name is when building for SYSTEM."
                                              (qemu qemu-headless)
                                              (env-vars '())
                                              (modules
-                                              '((guix build vm)
-                                                (guix build install)
-                                                (guix build linux-initrd)
-                                                (guix build utils)))
+                                              '((gnu build vm)
+                                                (gnu build install)
+                                                (gnu build linux-boot)
+                                                (gnu build file-systems)
+                                                (guix build utils)
+                                                (guix build store-copy)))
                                              (guile-for-build
                                               (%guile-for-build))
 
@@ -164,7 +166,7 @@ made available under the /xchg CIFS share."
       ;; Code that launches the VM that evaluates EXP.
       #~(begin
           (use-modules (guix build utils)
-                       (guix build vm))
+                       (gnu build vm))
 
           (let ((inputs  '#$(list qemu coreutils))
                 (linux   (string-append #$linux "/bzImage"))
@@ -217,48 +219,46 @@ INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
 the image."
-  (mlet %store-monad
-      ((graph (sequence %store-monad (map input->name+output inputs))))
-   (expression->derivation-in-linux-vm
-    name
-    #~(begin
-        (use-modules (guix build vm)
-                     (guix build utils))
+  (expression->derivation-in-linux-vm
+   name
+   #~(begin
+       (use-modules (gnu build vm)
+                    (guix build utils))
 
-        (let ((inputs
-               '#$(append (list qemu parted grub e2fsprogs util-linux)
-                          (map canonical-package
-                               (list sed grep coreutils findutils gawk))
-                          (if register-closures? (list guix) '())))
+       (let ((inputs
+              '#$(append (list qemu parted grub e2fsprogs util-linux)
+                         (map canonical-package
+                              (list sed grep coreutils findutils gawk))
+                         (if register-closures? (list guix) '())))
 
-              ;; This variable is unused but allows us to add INPUTS-TO-COPY
-              ;; as inputs.
-              (to-register
-                '#$(map (match-lambda
-                         ((name thing) thing)
-                         ((name thing output) `(,thing ,output)))
-                        inputs)))
+             ;; This variable is unused but allows us to add INPUTS-TO-COPY
+             ;; as inputs.
+             (to-register
+              '#$(map (match-lambda
+                       ((name thing) thing)
+                       ((name thing output) `(,thing ,output)))
+                      inputs)))
 
-          (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+         (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 
-          (let ((graphs '#$(match inputs
-                             (((names . _) ...)
-                              names))))
-            (initialize-hard-disk "/dev/vda"
-                                  #:system-directory #$os-derivation
-                                  #:grub.cfg #$grub-configuration
-                                  #:closures graphs
-                                  #:copy-closures? #$copy-inputs?
-                                  #:register-closures? #$register-closures?
-                                  #:disk-image-size #$disk-image-size
-                                  #:file-system-type #$file-system-type
-                                  #:file-system-label #$file-system-label)
-            (reboot))))
-    #:system system
-    #:make-disk-image? #t
-    #:disk-image-size disk-image-size
-    #:disk-image-format disk-image-format
-    #:references-graphs graph)))
+         (let ((graphs '#$(match inputs
+                            (((names . _) ...)
+                             names))))
+           (initialize-hard-disk "/dev/vda"
+                                 #:system-directory #$os-derivation
+                                 #:grub.cfg #$grub-configuration
+                                 #:closures graphs
+                                 #:copy-closures? #$copy-inputs?
+                                 #:register-closures? #$register-closures?
+                                 #:disk-image-size #$disk-image-size
+                                 #:file-system-type #$file-system-type
+                                 #:file-system-label #$file-system-label)
+           (reboot))))
+   #:system system
+   #:make-disk-image? #t
+   #:disk-image-size disk-image-size
+   #:disk-image-format disk-image-format
+   #:references-graphs inputs))
 
 
 ;;;

guix/build/pull.scm

@@ -21,6 +21,7 @@
   #:use-module (system base compile)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -47,43 +48,70 @@ normally, and 1 if an exception is raised."
     (pid
      #t)))
 
+(define* (report-build-progress total completed cont
+                                #:optional (log-port (current-error-port)))
+  "Report that COMPLETED out of TOTAL files have been completed, and call
+CONT."
+  (display #\cr log-port)
+  (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
+          (* 100. (/ completed total)) total)
+  (force-output log-port)
+  (cont))
+
 (define* (p-for-each proc lst
-                     #:optional (max-processes (current-processor-count)))
+                     #:optional (max-processes (current-processor-count))
+                     #:key (progress report-build-progress))
   "Invoke PROC for each element of LST in a separate process, using up to
-MAX-PROCESSES processes in parallel.  Raise an error if one of the processes
-exit with non-zero."
+MAX-PROCESSES processes in parallel.  Call PROGRESS at each step, passing it
+the continuation.  Raise an error if one of the processes exit with non-zero."
+  (define total
+    (length lst))
+
   (define (wait-for-one-process)
     (match (waitpid WAIT_ANY)
       ((_ . status)
        (unless (zero? (status:exit-val status))
          (error "process failed" proc status)))))
 
-  (let loop ((lst   lst)
-             (running 0))
+  (let loop ((lst       lst)
+             (running   0)
+             (completed 0))
     (match lst
       (()
        (or (zero? running)
-           (begin
+           (let ((running   (- running 1))
+                 (completed (+ completed 1)))
              (wait-for-one-process)
-             (loop lst (- running 1)))))
+             (progress total completed
+                       (lambda ()
+                         (loop lst running completed))))))
       ((head . tail)
        (if (< running max-processes)
-           (begin
+           (let ((running (+ 1 running)))
              (call-with-process (cut proc head))
-             (loop tail (+ running 1)))
-           (begin
+             (progress total completed
+                       (lambda ()
+                         (loop tail running completed))))
+           (let ((running   (- running 1))
+                 (completed (+ completed 1)))
              (wait-for-one-process)
-             (loop lst (- running 1))))))))
+             (progress total completed
+                       (lambda ()
+                         (loop lst running completed)))))))))
 
 (define* (build-guix out tarball
-                     #:key tar gzip gcrypt)
-  "Build and install Guix in directory OUT using source from TARBALL."
+                     #:key tar gzip gcrypt
+                     (debug-port (%make-void-port "w")))
+  "Build and install Guix in directory OUT using source from TARBALL.  Write
+any debugging output to DEBUG-PORT."
   (setvbuf (current-output-port) _IOLBF)
   (setvbuf (current-error-port) _IOLBF)
 
   (setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
 
-  (system* "tar" "xvf" tarball)
+  (format debug-port "extracting '~a'...~%" tarball)
+  (system* "tar" "xf" tarball)
+
   (match (scandir "." (lambda (name)
                         (and (not (member name '("." "..")))
                              (file-is-directory? name))))
@@ -92,11 +120,13 @@ exit with non-zero."
     (x
      (error "tarball did not produce a single source directory" x)))
 
-  (format #t "copying and compiling Guix to `~a'...~%" out)
+  (format #t "copying and compiling to '~a'...~%" out)
 
   ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
-  (copy-recursively "guix" (string-append out "/guix"))
-  (copy-recursively "gnu" (string-append out "/gnu"))
+  (copy-recursively "guix" (string-append out "/guix")
+                    #:log debug-port)
+  (copy-recursively "gnu" (string-append out "/gnu")
+                    #:log debug-port)
   (copy-file "guix.scm" (string-append out "/guix.scm"))
   (copy-file "gnu.scm" (string-append out "/gnu.scm"))
 
@@ -121,12 +151,12 @@ exit with non-zero."
   (p-for-each (lambda (file)
                 (let ((go (string-append (string-drop-right file 4)
                                          ".go")))
-                  (format (current-error-port)
-                          "compiling '~a'...~%" file)
-                  (compile-file file
-                                #:output-file go
-                                #:opts
-                                %auto-compilation-options)))
+                  (format debug-port "~%compiling '~a'...~%" file)
+                  (parameterize ((current-warning-port debug-port))
+                    (compile-file file
+                                  #:output-file go
+                                  #:opts
+                                  %auto-compilation-options))))
 
               (filter (cut string-suffix? ".scm" <>)
 
@@ -144,6 +174,7 @@ exit with non-zero."
   (delete-file (string-append out "/guix/config.scm"))
   (delete-file (string-append out "/guix/config.go"))
 
+  (newline)
   #t)
 
 ;;; pull.scm ends here

guix/build/store-copy.scm

@@ -0,0 +1,69 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build store-copy)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 rdelim)
+  #:export (read-reference-graph
+            populate-store))
+
+;;; Commentary:
+;;;
+;;; This module provides the tools to copy store items and their dependencies
+;;; to another store.  It relies on the availability of "reference graph"
+;;; files as produced by 'gexp->derivation' et al. with the
+;;; #:references-graphs parameter.
+;;;
+;;; Code:
+
+(define (read-reference-graph port)
+  "Return a list of store paths from the reference graph at PORT.
+The data at PORT is the format produced by #:references-graphs."
+  (let loop ((line   (read-line port))
+             (result '()))
+    (cond ((eof-object? line)
+           (delete-duplicates result))
+          ((string-prefix? "/" line)
+           (loop (read-line port)
+                 (cons line result)))
+          (else
+           (loop (read-line port)
+                 result)))))
+
+(define* (populate-store reference-graphs target)
+  "Populate the store under directory TARGET with the items specified in
+REFERENCE-GRAPHS, a list of reference-graph files."
+  (define store
+    (string-append target (%store-directory)))
+
+  (define (things-to-copy)
+    ;; Return the list of store files to copy to the image.
+    (define (graph-from-file file)
+      (call-with-input-file file read-reference-graph))
+
+    (delete-duplicates (append-map graph-from-file reference-graphs)))
+
+  (mkdir-p store)
+  (chmod store #o1775)
+  (for-each (lambda (thing)
+              (copy-recursively thing
+                                (string-append target thing)))
+            (things-to-copy)))
+
+;;; store-copy.scm ends here

guix/gexp.scm

@@ -109,6 +109,17 @@ the cross-compilation target triplet."
                      (return input)))
                    inputs))))
 
+(define* (lower-reference-graphs graphs #:key system target)
+  "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
+#:reference-graphs argument, lower it such that each INPUT is replaced by the
+corresponding derivation."
+  (match graphs
+    (((file-names . inputs) ...)
+     (mlet %store-monad ((inputs (lower-inputs inputs
+                                               #:system system
+                                               #:target target)))
+       (return (map cons file-names inputs))))))
+
 (define* (gexp->derivation name exp
                            #:key
                            system (target 'current)
@@ -127,10 +138,38 @@ names of Guile modules from the current search path to be copied in the store,
 compiled, and made available in the load path during the execution of
 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 
+When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
+following forms:
+
+  (FILE-NAME PACKAGE)
+  (FILE-NAME PACKAGE OUTPUT)
+  (FILE-NAME DERIVATION)
+  (FILE-NAME DERIVATION OUTPUT)
+  (FILE-NAME STORE-ITEM)
+
+The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
+an input of the build process of EXP.  In the build environment, each
+FILE-NAME contains the reference graph of the corresponding item, in a simple
+text format.
+
+In that case, the reference graph of each store path is exported in
+the build environment in the corresponding file, in a simple text format.
+
 The other arguments are as for 'derivation'."
   (define %modules modules)
   (define outputs (gexp-outputs exp))
 
+  (define (graphs-file-names graphs)
+    ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
+    (map (match-lambda
+           ((file-name (? derivation? drv))
+            (cons file-name (derivation->output-path drv)))
+           ((file-name (? derivation? drv) sub-drv)
+            (cons file-name (derivation->output-path drv sub-drv)))
+           ((file-name thing)
+            (cons file-name thing)))
+         graphs))
+
   (mlet* %store-monad (;; The following binding is here to force
                        ;; '%current-system' and '%current-target-system' to be
                        ;; looked up at >>= time.
@@ -162,6 +201,11 @@ The other arguments are as for 'derivation'."
                                                        #:system system
                                                        #:guile guile-for-build)
                                      (return #f)))
+                       (graphs   (if references-graphs
+                                     (lower-reference-graphs references-graphs
+                                                             #:system system
+                                                             #:target target)
+                                     (return #f)))
                        (guile    (if guile-for-build
                                      (return guile-for-build)
                                      (package->derivation (default-guile)
@@ -182,9 +226,12 @@ The other arguments are as for 'derivation'."
                                (,builder)
                                ,@(if modules
                                      `((,modules) (,compiled) ,@inputs)
-                                     inputs))
+                                     inputs)
+                               ,@(match graphs
+                                   (((_ . inputs) ...) inputs)
+                                   (_ '())))
                     #:hash hash #:hash-algo hash-algo #:recursive? recursive?
-                    #:references-graphs references-graphs
+                    #:references-graphs (and=> graphs graphs-file-names)
                     #:local-build? local-build?)))
 
 (define* (gexp-inputs exp #:optional (references gexp-references))
@@ -449,14 +496,16 @@ its search path."
                            (format port
                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
                                    (ungexp guile))
+
+                           ;; Write the 'eval-when' form so that it can be
+                           ;; compiled.
                            (write
-                            '(set! %load-path
-                                   (cons (ungexp modules) %load-path))
-                            port)
-                           (write
-                            '(set! %load-compiled-path
-                                   (cons (ungexp compiled)
-                                         %load-compiled-path))
+                            '(eval-when (expand load eval)
+                               (set! %load-path
+                                    (cons (ungexp modules) %load-path))
+                               (set! %load-compiled-path
+                                     (cons (ungexp compiled)
+                                           %load-compiled-path)))
                             port)
                            (write '(ungexp exp) port)
                            (chmod port #o555)))))))

guix/profiles.scm

@@ -32,6 +32,7 @@
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:export (manifest make-manifest
@@ -52,6 +53,7 @@
 
             manifest-remove
             manifest-add
+            manifest-lookup
             manifest-installed?
             manifest-matching-entries
 
@@ -60,6 +62,7 @@
             manifest-transaction-install
             manifest-transaction-remove
             manifest-perform-transaction
+            manifest-transaction-effects
             manifest-show-transaction
 
             profile-manifest
@@ -235,11 +238,16 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
                  (manifest-entries manifest)
                  entries))))
 
+(define (manifest-lookup manifest pattern)
+  "Return the first item of MANIFEST that matches PATTERN, or #f if there is
+no match.."
+  (find (entry-predicate pattern)
+        (manifest-entries manifest)))
+
 (define (manifest-installed? manifest pattern)
   "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
 #f otherwise."
-  (->bool (find (entry-predicate pattern)
-                (manifest-entries manifest))))
+  (->bool (manifest-lookup manifest pattern)))
 
 (define (manifest-matching-entries manifest patterns)
   "Return all the entries of MANIFEST that match one of the PATTERNS."
@@ -266,6 +274,39 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
   (remove  manifest-transaction-remove  ; list of <manifest-pattern>
            (default '())))
 
+(define (manifest-transaction-effects manifest transaction)
+  "Compute the effect of applying TRANSACTION to MANIFEST.  Return 3 values:
+the list of packages that would be removed, installed, or upgraded when
+applying TRANSACTION to MANIFEST.  Upgrades are represented as pairs where the
+head is the entry being upgraded and the tail is the entry that will replace
+it."
+  (define (manifest-entry->pattern entry)
+    (manifest-pattern
+      (name   (manifest-entry-name entry))
+      (output (manifest-entry-output entry))))
+
+  (let loop ((input    (manifest-transaction-install transaction))
+             (install '())
+             (upgrade '()))
+    (match input
+      (()
+       (let ((remove (manifest-transaction-remove transaction)))
+         (values (manifest-matching-entries manifest remove)
+                 (reverse install) (reverse upgrade))))
+      ((entry rest ...)
+       ;; Check whether installing ENTRY corresponds to the installation of a
+       ;; new package or to an upgrade.
+
+       ;; XXX: When the exact same output directory is installed, we're not
+       ;; really upgrading anything.  Add a check for that case.
+       (let* ((pattern  (manifest-entry->pattern entry))
+              (previous (manifest-lookup manifest pattern)))
+         (loop rest
+               (if previous install (cons entry install))
+               (if previous
+                   (alist-cons previous entry upgrade)
+                   upgrade)))))))
+
 (define (manifest-perform-transaction manifest transaction)
   "Perform TRANSACTION on MANIFEST and return new manifest."
   (let ((install (manifest-transaction-install transaction))
@@ -273,35 +314,48 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
     (manifest-add (manifest-remove manifest remove)
                   install)))
 
+(define (right-arrow port)
+  "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
+replacement if PORT is not Unicode-capable."
+  (with-fluids ((%default-port-encoding (port-encoding port)))
+    (let ((arrow "→"))
+      (catch 'encoding-error
+        (lambda ()
+          (with-fluids ((%default-port-conversion-strategy 'error))
+            (with-output-to-string
+              (lambda ()
+                (display arrow)))))
+        (lambda (key . args)
+          "->")))))
+
 (define* (manifest-show-transaction store manifest transaction
                                     #:key dry-run?)
   "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
   (define (package-strings name version output item)
     (map (lambda (name version output item)
-           (format #f "   ~a-~a\t~a\t~a" name version output
+           (format #f "   ~a~:[:~a~;~*~]\t~a\t~a"
+                   name
+                   (equal? output "out") output version
                    (if (package? item)
                        (package-output store item output)
                        item)))
          name version output item))
 
-  (let* ((remove (manifest-matching-entries
-                  manifest (manifest-transaction-remove transaction)))
-         (install/upgrade (manifest-transaction-install transaction))
-         (install '())
-         (upgrade (append-map
-                   (lambda (entry)
-                     (let ((matching
-                            (manifest-matching-entries
-                             manifest
-                             (list (manifest-pattern
-                                    (name   (manifest-entry-name entry))
-                                    (output (manifest-entry-output entry)))))))
-                       (when (null? matching)
-                         (set! install (cons entry install)))
-                       matching))
-                   install/upgrade)))
+  (define →                        ;an arrow that can be represented on stderr
+    (right-arrow (current-error-port)))
+
+  (define (upgrade-string name old-version new-version output item)
+    (format #f "   ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
+            name (equal? output "out") output
+            old-version → new-version
+            (if (package? item)
+                (package-output store item output)
+                item)))
+
+  (let-values (((remove install upgrade)
+                (manifest-transaction-effects manifest transaction)))
     (match remove
-      ((($ <manifest-entry> name version output item _) ..1)
+      ((($ <manifest-entry> name version output item) ..1)
        (let ((len    (length name))
              (remove (package-strings name version output item)))
          (if dry-run?
@@ -317,9 +371,11 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
                      remove))))
       (_ #f))
     (match upgrade
-      ((($ <manifest-entry> name version output item _) ..1)
+      (((($ <manifest-entry> name old-version)
+         . ($ <manifest-entry> _ new-version output item)) ..1)
        (let ((len     (length name))
-             (upgrade (package-strings name version output item)))
+             (upgrade (map upgrade-string
+                           name old-version new-version output item)))
          (if dry-run?
              (format (current-error-port)
                      (N_ "The following package would be upgraded:~%~{~a~%~}~%"

guix/scripts/build.scm

@@ -33,7 +33,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
-  #:autoload   (gnu packages) (find-best-packages-by-name)
+  #:autoload   (gnu packages) (specification->package)
   #:autoload   (guix download) (download-to-store)
   #:export (%standard-build-options
             set-build-options-from-command-line
@@ -41,27 +41,6 @@
 
             guix-build))
 
-(define (specification->package spec)
-  "Return a package matching SPEC.  SPEC may be a package name, or a package
-name followed by a hyphen and a version number.  If the version number is not
-present, return the preferred newest version."
-  (let-values (((name version)
-                (package-name->name+version spec)))
-    (match (find-best-packages-by-name name version)
-      ((p)                                      ; one match
-       p)
-      ((p x ...)                                ; several matches
-       (warning (_ "ambiguous package specification `~a'~%") spec)
-       (warning (_ "choosing ~a from ~a~%")
-                (package-full-name p)
-                (location->string (package-location p)))
-       p)
-      (_                                        ; no matches
-       (if version
-           (leave (_ "~A: package not found for version ~a~%")
-                  name version)
-           (leave (_ "~A: unknown package~%") name))))))
-
 (define (register-root store paths root)
   "Register ROOT as an indirect GC root for all of PATHS."
   (let* ((root (string-append (canonicalize-path (dirname root))

guix/scripts/lint.scm

@@ -0,0 +1,213 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts lint)
+  #:use-module (guix base32)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (gnu packages)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:export (guix-lint
+            check-inputs-should-be-native
+            check-patches
+            check-synopsis-style))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  '())
+
+(define (show-help)
+  (display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
+Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n"))
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -l, --list-checkers    display the list of available lint checkers"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  ;; TODO: add some options:
+  ;; * --checkers=checker1,checker2...: only run the specified checkers
+  ;; * --certainty=[low,medium,high]: only run checkers that have at least this
+  ;;                                  'certainty'.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\l "list-checkers") #f #f
+                (lambda args
+                   (list-checkers-and-exit)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix lint")))))
+
+
+;;;
+;;; Helpers
+;;;
+(define* (emit-warning package message #:optional field)
+  ;; Emit a warning about PACKAGE, printing the location of FIELD if it is
+  ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
+  ;; provided MESSAGE.
+  (let ((loc (or (package-field-location package field)
+                 (package-location package))))
+    (format (guix-warning-port) (_ "~a: ~a: ~a~%")
+            (location->string loc)
+            (package-full-name package)
+            message)))
+
+
+;;;
+;;; Checkers
+;;;
+(define-record-type* <lint-checker>
+  lint-checker make-lint-checker
+  lint-checker?
+  ;; TODO: add a 'certainty' field that shows how confident we are in the
+  ;; checker. Then allow users to only run checkers that have a certain
+  ;; 'certainty' level.
+  (name        lint-checker-name)
+  (description lint-checker-description)
+  (check       lint-checker-check))
+
+(define (list-checkers-and-exit)
+  ;; Print information about all available checkers and exit.
+  (format #t (_ "Available checkers:~%"))
+  (for-each (lambda (checker)
+              (format #t "- ~a: ~a~%"
+                      (lint-checker-name checker)
+                      (lint-checker-description checker)))
+            %checkers)
+  (exit 0))
+
+(define (check-inputs-should-be-native package)
+  ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
+  ;; native inputs.
+  (let ((inputs (package-inputs package)))
+    (match inputs
+      (((labels packages . _) ...)
+       (when (member "pkg-config"
+                     (map package-name (filter package? packages)))
+        (emit-warning package
+                      "pkg-config should probably be a native input"
+                      'inputs))))))
+
+
+(define (check-synopsis-style package)
+  ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
+  (define (check-final-period synopsis)
+    ;; Synopsis should not end with a period, except for some special cases.
+    (if (and (string=? (string-take-right synopsis 1) ".")
+             (not (string=? (string-take-right synopsis 4) "etc.")))
+        (emit-warning package
+                      "no period allowed at the end of the synopsis"
+                      'synopsis)))
+
+  (define (check-start-article synopsis)
+   (if (or (string=? (string-take synopsis 2) "A ")
+           (string=? (string-take synopsis 3) "An "))
+       (emit-warning package
+                     "no article allowed at the beginning of the synopsis"
+                     'synopsis)))
+
+ (let ((synopsis (package-synopsis package)))
+   (if (string? synopsis)
+       (begin
+        (check-final-period synopsis)
+        (check-start-article synopsis)))))
+
+(define (check-patches package)
+  ;; Emit a warning if the patches requires by PACKAGE are badly named.
+  (let ((patches   (and=> (package-source package) origin-patches))
+        (name      (package-name package))
+        (full-name (package-full-name package)))
+    (if (and patches
+             (any (lambda (patch)
+                    (let ((filename (basename patch)))
+                      (not (or (eq? (string-contains filename name) 0)
+                               (eq? (string-contains filename full-name) 0)))))
+                  patches))
+        (emit-warning package
+          "file names of patches should start with the package name"
+          'patches))))
+
+(define %checkers
+  (list
+   (lint-checker
+     (name        "inputs-should-be-native")
+     (description "Identify inputs that should be native inputs")
+     (check       check-inputs-should-be-native))
+   (lint-checker
+     (name        "patch-filenames")
+     (description "Validate filenames of patches")
+     (check       check-patches))
+   (lint-checker
+     (name        "synopsis")
+     (description "Validate package synopsis")
+     (check       check-synopsis-style))))
+
+(define (run-checkers package)
+  ;; Run all the checkers on PACKAGE.
+  (for-each (lambda (checker)
+              ((lint-checker-check checker) package))
+            %checkers))
+
+
+;;;
+;;; Entry Point
+;;;
+
+(define (guix-lint . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold* args %options
+                (lambda (opt name arg result)
+                  (leave (_ "~A: unrecognized option~%") name))
+                (lambda (arg result)
+                  (alist-cons 'argument arg result))
+                %default-options))
+
+  (let* ((opts (parse-options))
+         (args (filter-map (match-lambda
+                            (('argument . value)
+                             value)
+                            (_ #f))
+                           (reverse opts))))
+
+
+   (if (null? args)
+        (fold-packages (lambda (p r) (run-checkers p)) '())
+        (for-each
+          (lambda (spec)
+            (run-checkers spec))
+          (map specification->package args)))))

guix/scripts/offload.scm

@@ -181,7 +181,8 @@ determined."
                       #:key (error-port (current-error-port)) (quote? #t))
   "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
 set up.  When QUOTE? is true, perform shell-quotation of all the elements of
-COMMAND."
+COMMAND.  Return either a pipe opened with MODE, or #f if the lsh client could
+not be started."
   (define (shell-quote str)
     ;; Sort-of shell-quote STR so it can be passed as an argument to the
     ;; shell.
@@ -315,8 +316,17 @@ hook."
        (let ((root-directory (string-append %state-directory
                                             "/gcroots/tmp")))
          (false-if-exception (mkdir root-directory))
-         (symlink ,file
-                  (string-append root-directory "/" ,%gc-root-file)))))
+         (catch 'system-error
+           (lambda ()
+             (symlink ,file
+                      (string-append root-directory "/" ,%gc-root-file)))
+           (lambda args
+             ;; If FILE already exists, we can assume that either it's a stale
+             ;; reference (which is fine), or another process is already
+             ;; building the derivation represented by FILE (which is fine
+             ;; too.)  Thus, do nothing in that case.
+             (unless (= EEXIST (system-error-errno args))
+               (apply throw args)))))))
 
   (let ((pipe (remote-pipe machine OPEN_READ
                            `("guile" "-c" ,(object->string script)))))
@@ -535,7 +545,7 @@ allowed on MACHINE."
          (line (read-line pipe)))
     (close-pipe pipe)
     (if (eof-object? line)
-        1.
+        +inf.0    ;MACHINE does not respond, so assume it is infinitely loaded
         (match (string-tokenize line)
           ((one five fifteen . _)
            (let* ((raw        (string->number five))
@@ -546,7 +556,7 @@ allowed on MACHINE."
                      (build-machine-name machine) raw normalized)
              normalized))
           (_
-           1.)))))
+           +inf.0)))))           ;something's fishy about MACHINE, so avoid it
 
 (define (machine-less-loaded? m1 m2)
   "Return #t if the load on M1 is lower than that on M2."

guix/scripts/package.scm

@@ -305,10 +305,12 @@ current settings and report only settings not already effective."
         ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
         ;; the former traverses the module tree only once and then allows for
         ;; efficient access via a vhash.
-        (match (or (find-best-packages-by-name name version)
-                   (find-best-packages-by-name name #f))
+        (match (find-best-packages-by-name name version)
           ((p _ ...) p)
-          (_ #f)))))
+          (_
+           (match (find-best-packages-by-name name #f)
+             ((p _ ...) p)
+             (_ #f)))))))
 
     (define search-path-definition
       (match-lambda

guix/scripts/pull.scm

@@ -38,15 +38,21 @@
   "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
   )
 
-(define (unpack store tarball)
+(define* (unpack store tarball #:key verbose?)
   "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
 files."
   (define builder
-    '(begin
+    `(begin
        (use-modules (guix build pull))
 
        (build-guix (assoc-ref %outputs "out")
                    (assoc-ref %build-inputs "tarball")
+
+                   ;; XXX: This is not perfect, enabling VERBOSE? means
+                   ;; building a different derivation.
+                   #:debug-port (if ',verbose?
+                                    (current-error-port)
+                                    (%make-void-port "w"))
                    #:tar (assoc-ref %build-inputs "tar")
                    #:gzip (assoc-ref %build-inputs "gzip")
                    #:gcrypt (assoc-ref %build-inputs "gcrypt"))))
@@ -129,13 +135,10 @@ Download and deploy the latest version of Guix.\n"))
                         (package-derivation store
                                             (if (assoc-ref opts 'bootstrap?)
                                                 %bootstrap-guile
-                                                (canonical-package guile-2.0))))
-                       (current-build-output-port
-                        (if (assoc-ref opts 'verbose?)
-                            (current-error-port)
-                            (%make-void-port "w"))))
+                                                (canonical-package guile-2.0)))))
           (let* ((config-dir (config-directory))
-                 (source     (unpack store tarball))
+                 (source     (unpack store tarball
+                                     #:verbose? (assoc-ref opts 'verbose?)))
                  (source-dir (derivation->output-path source)))
             (if (show-what-to-build store (list source))
                 (if (build-derivations store (list source))

guix/scripts/system.scm

@@ -28,7 +28,7 @@
   #:use-module (guix profiles)
   #:use-module (guix scripts build)
   #:use-module (guix build utils)
-  #:use-module (guix build install)
+  #:use-module (gnu build install)
   #:use-module (gnu system)
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)

nix/nix-daemon/guix-daemon.cc

@@ -62,7 +62,7 @@ builds derivations on behalf of its clients.";
 #define GUIX_OPT_CACHE_FAILURES 4
 #define GUIX_OPT_LOSE_LOGS 5
 #define GUIX_OPT_DISABLE_LOG_COMPRESSION 6
-#define GUIX_OPT_DISABLE_STORE_OPTIMIZATION 7
+#define GUIX_OPT_DISABLE_DEDUPLICATION 7
 #define GUIX_OPT_IMPERSONATE_LINUX_26 8
 #define GUIX_OPT_DEBUG 9
 #define GUIX_OPT_CHROOT_DIR 10
@@ -106,8 +106,14 @@ static const struct argp_option options[] =
       "Do not keep build logs" },
     { "disable-log-compression", GUIX_OPT_DISABLE_LOG_COMPRESSION, 0, 0,
       "Disable compression of the build logs" },
-    { "disable-store-optimization", GUIX_OPT_DISABLE_STORE_OPTIMIZATION, 0, 0,
+
+    /* '--disable-deduplication' was known as '--disable-store-optimization'
+       up to Guix 0.7 included, so keep the alias around.  */
+    { "disable-deduplication", GUIX_OPT_DISABLE_DEDUPLICATION, 0, 0,
       "Disable automatic file \"deduplication\" in the store" },
+    { "disable-store-optimization", GUIX_OPT_DISABLE_DEDUPLICATION, 0,
+      OPTION_ALIAS | OPTION_HIDDEN, NULL },
+
     { "impersonate-linux-2.6", GUIX_OPT_IMPERSONATE_LINUX_26, 0, 0,
       "Impersonate Linux 2.6"
 #ifndef HAVE_SYS_PERSONALITY_H
@@ -163,7 +169,7 @@ parse_opt (int key, char *arg, struct argp_state *state)
     case GUIX_OPT_BUILD_USERS_GROUP:
       settings.buildUsersGroup = arg;
       break;
-    case GUIX_OPT_DISABLE_STORE_OPTIMIZATION:
+    case GUIX_OPT_DISABLE_DEDUPLICATION:
       settings.autoOptimiseStore = false;
       break;
     case GUIX_OPT_CACHE_FAILURES:
@@ -249,6 +255,9 @@ main (int argc, char *argv[])
   settings.useChroot = false;
 #endif
 
+  /* Turn automatic deduplication on by default.  */
+  settings.autoOptimiseStore = true;
+
   argvSaved = argv;
 
   try
@@ -325,6 +334,10 @@ main (int argc, char *argv[])
 	}
 #endif
 
+      printMsg (lvlDebug,
+		format ("automatic deduplication set to %1%")
+		% settings.autoOptimiseStore);
+
       printMsg (lvlDebug,
 		format ("listening on `%1%'") % settings.nixDaemonSocketFile);
 

nix/sync-with-upstream

@@ -1,6 +1,6 @@
 #!/bin/sh
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -65,7 +65,16 @@ done
 rm -fv "$top_srcdir/nix/libstore/schema.sql.hh"
 
 cp -v "$top_srcdir/nix-upstream/COPYING" "$top_srcdir/nix"
-cp -v "$top_srcdir/nix-upstream/AUTHORS" "$top_srcdir/nix"
+
+# Generate an 'AUTHORS' file since upstream Nix no longer has one.
+cat > "$top_srcdir/nix/AUTHORS" <<EOF
+Most of the code is this directory was written by the following people for
+the Nix project (http://nixos.org/nix).  Thank you!
+
+EOF
+( cd "$top_srcdir/nix-upstream" ; git shortlog --summary )	\
+    | sed -'es/^ *[0-9]\+\(.*\)/   \1/g'			\
+    >> "$top_srcdir/nix/AUTHORS"
 
 # Substitutions.
 sed -i "$top_srcdir/nix/libstore/gc.cc"					\

po/guix/Makevars

@@ -10,7 +10,8 @@ top_builddir = ../..
 XGETTEXT_OPTIONS =				\
   --language=Scheme --from-code=UTF-8		\
   --keyword=_ --keyword=N_			\
-  --keyword=message
+  --keyword=message				\
+  --keyword=description
 
 COPYRIGHT_HOLDER = Ludovic Courtès
 

po/guix/POTFILES.in

@@ -10,6 +10,7 @@ guix/scripts/pull.scm
 guix/scripts/substitute-binary.scm
 guix/scripts/authenticate.scm
 guix/scripts/system.scm
+guix/scripts/lint.scm
 guix/gnu-maintenance.scm
 guix/ui.scm
 guix/http-client.scm

tests/derivations.scm

@@ -151,6 +151,28 @@
          ;; the contents.
          (valid-path? %store (derivation->output-path drv)))))
 
+(test-assert "identical files are deduplicated"
+  (let* ((build1  (add-text-to-store %store "one.sh"
+                                     "echo hello, world > \"$out\"\n"
+                                     '()))
+         (build2  (add-text-to-store %store "two.sh"
+                                     "# Hey!\necho hello, world > \"$out\"\n"
+                                     '()))
+         (drv1    (derivation %store "foo"
+                              %bash `(,build1)
+                              #:inputs `((,%bash) (,build1))))
+         (drv2    (derivation %store "bar"
+                              %bash `(,build2)
+                              #:inputs `((,%bash) (,build2)))))
+    (and (build-derivations %store (list drv1 drv2))
+         (let ((file1 (derivation->output-path drv1))
+               (file2 (derivation->output-path drv2)))
+           (and (valid-path? %store file1) (valid-path? %store file2)
+                (string=? (call-with-input-file file1 get-string-all)
+                          "hello, world\n")
+                (= (stat:ino (lstat file1))
+                   (stat:ino (lstat file2))))))))
+
 (test-assert "fixed-output-derivation?"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))

tests/gexp.scm

@@ -324,6 +324,78 @@
     (return (string=? (derivation-file-name drv)
                       (derivation-file-name xdrv)))))
 
+(test-assertm "gexp->derivation, store copy"
+  (let ((build-one #~(call-with-output-file #$output
+                       (lambda (port)
+                         (display "This is the one." port))))
+        (build-two (lambda (one)
+                     #~(begin
+                         (mkdir #$output)
+                         (symlink #$one (string-append #$output "/one"))
+                         (call-with-output-file (string-append #$output "/two")
+                           (lambda (port)
+                             (display "This is the second one." port))))))
+        (build-drv #~(begin
+                       (use-modules (guix build store-copy))
+
+                       (mkdir #$output)
+                       (populate-store '("graph") #$output))))
+    (mlet* %store-monad ((one (gexp->derivation "one" build-one))
+                         (two (gexp->derivation "two" (build-two one)))
+                         (drv (gexp->derivation "store-copy" build-drv
+                                                #:references-graphs
+                                                `(("graph" ,two))
+                                                #:modules
+                                                '((guix build store-copy)
+                                                  (guix build utils))))
+                         (ok? (built-derivations (list drv)))
+                         (out -> (derivation->output-path drv)))
+      (let ((one (derivation->output-path one))
+            (two (derivation->output-path two)))
+        (return (and ok?
+                     (file-exists? (string-append out "/" one))
+                     (file-exists? (string-append out "/" two))
+                     (file-exists? (string-append out "/" two "/two"))
+                     (string=? (readlink (string-append out "/" two "/one"))
+                               one)))))))
+
+(test-assertm "gexp->derivation #:references-graphs"
+  (mlet* %store-monad
+      ((one (text-file "one" "hello, world"))
+       (two (gexp->derivation "two"
+                              #~(symlink #$one #$output:chbouib)))
+       (drv (gexp->derivation "ref-graphs"
+                              #~(begin
+                                  (use-modules (guix build store-copy))
+                                  (with-output-to-file #$output
+                                    (lambda ()
+                                      (write (call-with-input-file "guile"
+                                               read-reference-graph))))
+                                  (with-output-to-file #$output:one
+                                    (lambda ()
+                                      (write (call-with-input-file "one"
+                                               read-reference-graph))))
+                                  (with-output-to-file #$output:two
+                                    (lambda ()
+                                      (write (call-with-input-file "two"
+                                               read-reference-graph)))))
+                              #:references-graphs `(("one" ,one)
+                                                    ("two" ,two "chbouib")
+                                                    ("guile" ,%bootstrap-guile))
+                              #:modules '((guix build store-copy)
+                                          (guix build utils))))
+       (ok? (built-derivations (list drv)))
+       (guile-drv  (package->derivation %bootstrap-guile))
+       (g-one   -> (derivation->output-path drv "one"))
+       (g-two   -> (derivation->output-path drv "two"))
+       (g-guile -> (derivation->output-path drv)))
+    (return (and ok?
+                 (equal? (call-with-input-file g-one read) (list one))
+                 (equal? (call-with-input-file g-two read)
+                         (list one (derivation->output-path two "chbouib")))
+                 (equal? (call-with-input-file g-guile read)
+                         (list (derivation->output-path guile-drv)))))))
+
 (define shebang
   (string-append "#!" (derivation->output-path (%guile-for-build))
                  "/bin/guile --no-auto-compile"))

tests/lint.scm

@@ -0,0 +1,110 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(define-module (test-packages)
+  #:use-module (guix build download)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix packages)
+  #:use-module (guix scripts lint)
+  #:use-module (guix ui)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (srfi srfi-64))
+
+;; Test the linter.
+
+
+(test-begin "lint")
+
+(define-syntax-rule (dummy-package name* extra-fields ...)
+  (package extra-fields ... (name name*) (version "0") (source #f)
+           (build-system gnu-build-system)
+           (synopsis #f) (description #f)
+           (home-page #f) (license #f) ))
+
+(define (call-with-warnings thunk)
+  (let ((port (open-output-string)))
+    (parameterize ((guix-warning-port port))
+      (thunk))
+    (get-output-string port)))
+
+(test-assert "synopsis: ends with a period"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "Bad synopsis."))))
+                          (check-synopsis-style pkg))))
+                    "no period allowed at the end of the synopsis")))
+
+(test-assert "synopsis: ends with 'etc.'"
+  (->bool
+   (string-null? (call-with-warnings
+                   (lambda ()
+                     (let ((pkg (dummy-package "x"
+                                  (synopsis "Foo, bar, etc."))))
+                       (check-synopsis-style pkg)))))))
+
+(test-assert "synopsis: starts with 'A'"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "A bad synopŝis"))))
+                          (check-synopsis-style pkg))))
+                    "no article allowed at the beginning of the synopsis")))
+
+(test-assert "synopsis: starts with 'An'"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "An awful synopsis"))))
+                        (check-synopsis-style pkg))))
+                    "no article allowed at the beginning of the synopsis")))
+
+(test-assert "inputs: pkg-config is probably a native input"
+  (->bool
+   (string-contains
+     (call-with-warnings
+       (lambda ()
+         (let ((pkg (dummy-package "x"
+                      (inputs `(("pkg-config" ,pkg-config))))))
+              (check-inputs-should-be-native pkg))))
+         "pkg-config should probably be a native input")))
+
+(test-assert "patches: file names"
+  (->bool
+   (string-contains
+     (call-with-warnings
+       (lambda ()
+         (let ((pkg (dummy-package "x"
+                      (source
+                       (origin
+                        (method url-fetch)
+                        (uri "someurl")
+                        (sha256 "somesha")
+                        (patches (list "/path/to/y.patch")))))))
+              (check-patches pkg))))
+         "file names of patches should start with the package name")))
+
+(test-end "lint")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))

tests/profiles.scm

@@ -26,6 +26,8 @@
   #:use-module (guix derivations)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64))
 
 ;; Test the (guix profiles) module.
@@ -53,6 +55,13 @@
   (manifest-entry (inherit guile-2.0.9)
     (output "debug")))
 
+(define glibc
+  (manifest-entry
+    (name "glibc")
+    (version "2.19")
+    (item "/gnu/store/...")
+    (output "out")))
+
 
 (test-begin "profiles")
 
@@ -136,6 +145,34 @@
          (equal? m1 m2)
          (null? (manifest-entries m3)))))
 
+(test-assert "manifest-transaction-effects"
+  (let* ((m0 (manifest (list guile-1.8.8)))
+         (t  (manifest-transaction
+              (install (list guile-2.0.9 glibc))
+              (remove (list (manifest-pattern (name "coreutils")))))))
+    (let-values (((remove install upgrade)
+                  (manifest-transaction-effects m0 t)))
+      (and (null? remove)
+           (equal? (list glibc) install)
+           (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
+
+(test-assert "manifest-show-transaction"
+  (let* ((m (manifest (list guile-1.8.8)))
+         (t (manifest-transaction (install (list guile-2.0.9)))))
+    (let-values (((remove install upgrade)
+                  (manifest-transaction-effects m t)))
+      (with-store store
+        (and (string-match "guile\t1.8.8 → 2.0.9"
+                           (with-fluids ((%default-port-encoding "UTF-8"))
+                             (with-error-to-string
+                              (lambda ()
+                                (manifest-show-transaction store m t)))))
+             (string-match "guile\t1.8.8 -> 2.0.9"
+                           (with-fluids ((%default-port-encoding "ISO-8859-1"))
+                             (with-error-to-string
+                              (lambda ()
+                                (manifest-show-transaction store m t))))))))))
+
 (test-assert "profile-derivation"
   (run-with-store %store
     (mlet* %store-monad