diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | doc/guix.texi | 44 | ||||
| -rw-r--r-- | gnu-system.am | 1 | ||||
| -rw-r--r-- | gnu/packages/algebra.scm | 10 | ||||
| -rw-r--r-- | gnu/packages/gnome.scm | 71 | ||||
| -rw-r--r-- | gnu/packages/libcanberra.scm | 31 | ||||
| -rw-r--r-- | gnu/packages/linux.scm | 30 | ||||
| -rw-r--r-- | gnu/packages/patches/libcanberra-sound-theme-freedesktop.patch | 22 | ||||
| -rw-r--r-- | gnu/packages/pdf.scm | 42 | ||||
| -rw-r--r-- | gnu/packages/video.scm | 8 | ||||
| -rw-r--r-- | gnu/packages/xdisorg.scm | 33 | ||||
| -rw-r--r-- | gnu/packages/xlockmore.scm | 52 | ||||
| -rw-r--r-- | gnu/services/base.scm | 10 | ||||
| -rw-r--r-- | guix/build-system/glib-or-gtk.scm | 30 | ||||
| -rw-r--r-- | guix/build/glib-or-gtk-build-system.scm | 139 | ||||
| -rw-r--r-- | guix/derivations.scm | 25 | ||||
| -rw-r--r-- | guix/gexp.scm | 17 | ||||
| -rw-r--r-- | guix/monads.scm | 73 | ||||
| -rw-r--r-- | guix/sets.scm | 116 | ||||
| -rw-r--r-- | tests/gexp.scm | 26 | ||||
| -rw-r--r-- | tests/lint.scm | 23 | ||||
| -rw-r--r-- | tests/monads.scm | 47 | ||||
| -rw-r--r-- | tests/sets.scm | 52 |
23 files changed, 637 insertions, 269 deletions
diff --git a/Makefile.am b/Makefile.am index 5ee743470b..c482848fdf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013 Andreas Enge <andreas@enge.fr> # # This file is part of GNU Guix. @@ -34,6 +34,7 @@ MODULES = \ guix/pk-crypto.scm \ guix/pki.scm \ guix/utils.scm \ + guix/sets.scm \ guix/download.scm \ guix/git-download.scm \ guix/monads.scm \ @@ -153,6 +154,7 @@ SCM_TESTS = \ tests/hash.scm \ tests/pk-crypto.scm \ tests/pki.scm \ + tests/sets.scm \ tests/substitute-binary.scm \ tests/builders.scm \ tests/derivations.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 55e63f35b5..1739f3268d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -124,7 +124,7 @@ Utilities GNU Distribution * System Installation:: Installing the whole operating system. -* System Configuration:: Configuring a GNU system. +* System Configuration:: Configuring the operating system. * Installing Debugging Files:: Feeding the debugger. * Security Updates:: Deploying security fixes quickly. * Package Modules:: Packages from the programmer's viewpoint. @@ -3233,13 +3233,23 @@ build} supports (@pxref{Invoking guix build, common build options}). @node GNU Distribution @chapter GNU Distribution +@cindex Guixotic Guix comes with a distribution of free software@footnote{The term ``free'' here refers to the @url{http://www.gnu.org/philosophy/free-sw.html,freedom provided to -users of that software}.} that forms the basis of the GNU system. This -includes core GNU packages such as GNU libc, GCC, and Binutils, as well -as many GNU and non-GNU applications. The complete list of available -packages can be browsed +users of that software}.} that forms the basis of the GNU system. The +distribution can be installed on its own (@pxref{System Installation}), +but it is also possible to install Guix as a package manager on top of +an installed GNU/Linux system (@pxref{Installation}). To distinguish +between the two, we refer to the standalone distribution as +``Guixotic''@footnote{``How am I going to pronounce that name?'', you +may ask. Well, we would pronounce it like ``geeks-otic'', for +consistency with Guix---which is quite different from the usual +pronunciation of ``quixotic''.}. + +The distribution provides core GNU packages such as GNU libc, GCC, and +Binutils, as well as many GNU and non-GNU applications. The complete +list of available packages can be browsed @url{http://www.gnu.org/software/guix/package-list.html,on-line} or by running @command{guix package} (@pxref{Invoking guix package}): @@ -3247,7 +3257,7 @@ running @command{guix package} (@pxref{Invoking guix package}): guix package --list-available @end example -Our goal is to build a practical 100% free software distribution of +Our goal has been to provide a practical 100% free software distribution of Linux-based and other variants of GNU, with a focus on the promotion and tight integration of GNU components, and an emphasis on programs and tools that help users exert that freedom. @@ -3278,7 +3288,7 @@ For information on porting to other architectures or kernels, @menu * System Installation:: Installing the whole operating system. -* System Configuration:: Configuring a GNU system. +* System Configuration:: Configuring the operating system. * Installing Debugging Files:: Feeding the debugger. * Security Updates:: Deploying security fixes quickly. * Package Modules:: Packages from the programmer's viewpoint. @@ -3293,9 +3303,11 @@ to join! @xref{Contributing}, for information about how you can help. @node System Installation @section System Installation -This section explains how to install the complete GNU operating system -on a machine. The Guix package manager can also be installed on top of -a running GNU/Linux system, @pxref{Installation}. +@cindex Guixotic +This section explains how to install the standalone distribution, +code-named ``Guixotic'', on a machine. The Guix package manager can +also be installed on top of a running GNU/Linux system, +@pxref{Installation}. @ifinfo @c This paragraph is for people reading this from tty2 of the @@ -3308,13 +3320,13 @@ link that follows: @pxref{Help,,, info, Info: An Introduction}. Hit @subsection Limitations -As of version @value{VERSION}, GNU@tie{}Guix and the GNU system -distribution are alpha software. It may contain bugs and lack important +As of version @value{VERSION}, GNU@tie{}Guix and Guixotic are +not production-ready. They may contain bugs and lack important features. Thus, if you are looking for a stable production system that respects your freedom as a computer user, a good solution at this point is to consider @url{http://www.gnu.org/distros/free-distros.html, one of more established GNU/Linux distributions}. We hope you can soon switch -to the GNU system without fear, of course. In the meantime, you can +to Guixotic without fear, of course. In the meantime, you can also keep using your distribution and try out the package manager on top of it (@pxref{Installation}). @@ -3498,7 +3510,7 @@ about the installation image. @section System Configuration @cindex system configuration -The GNU system supports a consistent whole-system configuration +Guixotic supports a consistent whole-system configuration mechanism. By that we mean that all aspects of the global system configuration---such as the available system services, timezone and locale settings, user accounts---are declared in a single place. Such @@ -4639,7 +4651,7 @@ The type of an entry in the GRUB boot menu. @table @asis @item @code{label} -The label to show in the menu---e.g., @code{"GNU System"}. +The label to show in the menu---e.g., @code{"GNU"}. @item @code{linux} The Linux kernel to boot. @@ -4709,7 +4721,7 @@ This action does not actually install anything. @item init Populate the given directory with all the files necessary to run the operating system specified in @var{file}. This is useful for first-time -installations of the GNU system. For instance: +installations of Guixotic. For instance: @example guix system init my-os-config.scm /mnt diff --git a/gnu-system.am b/gnu-system.am index a166adda2d..4473651ab9 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -277,7 +277,6 @@ GNU_SYSTEM_MODULES = \ gnu/packages/wv.scm \ gnu/packages/xfig.scm \ gnu/packages/xiph.scm \ - gnu/packages/xlockmore.scm \ gnu/packages/xml.scm \ gnu/packages/xnee.scm \ gnu/packages/xdisorg.scm \ diff --git a/gnu/packages/algebra.scm b/gnu/packages/algebra.scm index b212aa67a9..2973c68675 100644 --- a/gnu/packages/algebra.scm +++ b/gnu/packages/algebra.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2012, 2013, 2014, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; @@ -83,14 +83,14 @@ solve the shortest vector problem.") (define-public pari-gp (package (name "pari-gp") - (version "2.7.1") + (version "2.7.2") (source (origin (method url-fetch) (uri (string-append "http://pari.math.u-bordeaux.fr/pub/pari/unix/pari-" version ".tar.gz")) (sha256 (base32 - "1gj1rddi22hinzwy7r6hljgbi252wwwyd6gapg4hvcn0ycc7jqyc")))) + "1b0hzyhafpxhmiljyhnsh6c27ydsvb2599fshwq2fjfm96awjxmc")))) (build-system gnu-build-system) (inputs `(("gmp" ,gmp) ("perl" ,perl) @@ -123,14 +123,14 @@ PARI is also available as a C library to allow for faster computations.") (define-public gp2c (package (name "gp2c") - (version "0.0.9pl1") + (version "0.0.9pl2") (source (origin (method url-fetch) (uri (string-append "http://pari.math.u-bordeaux.fr/pub/pari/GP2C/gp2c-" version ".tar.gz")) (sha256 (base32 - "1p36060vwhn38j77r4c3jqyaslvhvgm6fdw2486k7krxk5ai7ph5")))) + "02h35fwz1caicii7fj8zb9ky4hcrd8rqmzkyvhbls0r05yg5bwwb")))) (build-system gnu-build-system) (native-inputs `(("perl" ,perl))) (inputs `(("pari-gp" ,pari-gp))) diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 61260557e3..408ba4e816 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -209,19 +209,7 @@ and keep up to date translations of documentation.") ;; FIXME: Tests fail with: ;; ImportError: No module named gi.repository ;; Where should that module come from? - #:tests? #f - - #:phases (alist-cons-after - 'install 'set-mime-search-path - (lambda* (#:key inputs outputs #:allow-other-keys) - ;; Wrap 'evince' so that it knows where MIME info is. - (let ((out (assoc-ref outputs "out")) - (mime (assoc-ref inputs "shared-mime-info"))) - (wrap-program (string-append out "/bin/evince") - `("XDG_DATA_DIRS" ":" prefix - ,(list (string-append mime "/share") - (string-append out "/share")))))) - %standard-phases))) + #:tests? #f)) (inputs `(("libspectre" ,libspectre) ;; ("djvulibre" ,djvulibre) @@ -240,7 +228,9 @@ and keep up to date translations of documentation.") ("libsm" ,libsm) ("libice" ,libice) ("shared-mime-info" ,shared-mime-info) - + ("dconf" ,dconf) + ("libcanberra" ,libcanberra) + ;; For tests. ("dogtail" ,python2-dogtail))) (native-inputs @@ -1381,3 +1371,56 @@ editors, IDEs, etc.") (propagated-inputs `(("gtk+" ,gtk+-2) ; required by libvte.pc ("ncurses" ,ncurses))))) ; required by libvte.la + +(define-public dconf + (package + (name "dconf") + (version "0.22.0") + (source (origin + (method url-fetch) + (uri (string-append + "mirror://gnome/sources/" name "/" + (version-major+minor version) "/" + name "-" version ".tar.xz")) + (sha256 + (base32 "13jb49504bir814v8n8vjip5sazwfwsrnniw87cpg7phqfq7q9qa")))) + (build-system glib-or-gtk-build-system) + (inputs + `(("gtk+" ,gtk+) + ("glib" ,glib) + ("dbus" ,dbus) + ("libxml2" ,libxml2))) + (native-inputs + `(("libxslt" ,libxslt) + ("docbook-xml" ,docbook-xml-4.2) + ("docbook-xsl" ,docbook-xsl) + ("intltool" ,intltool) + ("pkg-config" ,pkg-config))) + (arguments + `(#:tests? #f ; To contact dbus it needs to load /var/lib/dbus/machine-id + ; or /etc/machine-id. + #:configure-flags + ;; Set the correct RUNPATH in binaries. + (list (string-append "LDFLAGS=-Wl,-rpath=" + (assoc-ref %outputs "out") "/lib") + "--disable-gtk-doc-html") ; FIXME: requires gtk-doc + #:phases + (alist-cons-before + 'configure 'fix-docbook + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "docs/Makefile.in" + (("http://docbook.sourceforge.net/release/xsl/current/manpages/docbook.xsl") + (string-append (assoc-ref inputs "docbook-xsl") + "/xml/xsl/docbook-xsl-" + ,(package-version docbook-xsl) + "/manpages/docbook.xsl"))) + (setenv "XML_CATALOG_FILES" + (string-append (assoc-ref inputs "docbook-xml") + "/xml/dtd/docbook/catalog.xml"))) + %standard-phases))) + (home-page "https://developer.gnome.org/dconf") + (synopsis "Low-level GNOME configuration system") + (description "Dconf is a low-level configuration system. Its main purpose +is to provide a backend to GSettings on platforms that don't already have +configuration storage systems.") + (license license:lgpl2.1))) diff --git a/gnu/packages/libcanberra.scm b/gnu/packages/libcanberra.scm index 859740aaee..0ffae1f674 100644 --- a/gnu/packages/libcanberra.scm +++ b/gnu/packages/libcanberra.scm @@ -19,6 +19,7 @@ (define-module (gnu packages libcanberra) #:use-module ((guix licenses) #:select (lgpl2.1+)) + #:use-module (gnu packages) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -46,7 +47,21 @@ version ".tar.xz")) (sha256 (base32 - "0wps39h8rx2b00vyvkia5j40fkak3dpipp1kzilqla0cgvk73dn2")))) + "0wps39h8rx2b00vyvkia5j40fkak3dpipp1kzilqla0cgvk73dn2")) + ;; "sound-theme-freedesktop" is the default and fall-back sound theme for + ;; XDG desktops and should always be present. + ;; http://www.freedesktop.org/wiki/Specifications/sound-theme-spec/ + ;; We make sure libcanberra will find it. + ;; + ;; We add the default sounds store directory to the code dealing with + ;; XDG_DATA_DIRS and not XDG_DATA_HOME. This is because XDG_DATA_HOME + ;; can only be a single directory and is inspected first. XDG_DATA_DIRS + ;; can list an arbitrary number of directories and is only inspected + ;; later. This is designed to allows the user to modify any theme at + ;; his pleasure. + (patch-flags '("-p0")) + (patches + (list (search-patch "libcanberra-sound-theme-freedesktop.patch"))))) (build-system gnu-build-system) (inputs `(("alsa-lib" ,alsa-lib) @@ -55,9 +70,21 @@ ("libltdl" ,libltdl) ("libvorbis" ,libvorbis) ("pulseaudio" ,pulseaudio) - ("udev" ,eudev))) + ("udev" ,eudev) + ("sound-theme-freedesktop" ,sound-theme-freedesktop))) (native-inputs `(("pkg-config" ,pkg-config))) + (arguments + `(#:phases + (alist-cons-before + 'build 'patch-default-sounds-directory + (lambda* (#:key inputs #:allow-other-keys) + (substitute* "src/sound-theme-spec.c" + (("@SOUND_THEME_DIRECTORY@") + (string-append + (assoc-ref inputs "sound-theme-freedesktop") + "/share")))) + %standard-phases))) (home-page "http://0pointer.de/lennart/projects/libcanberra/") (synopsis "Implementation of the XDG Sound Theme and Name Specifications") diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index 727d14bbdf..efc7fb7b3f 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -905,7 +905,7 @@ transparently through a bridge.") (define-public libnl (package (name "libnl") - (version "3.2.13") + (version "3.2.25") (source (origin (method url-fetch) (uri (string-append @@ -913,7 +913,7 @@ transparently through a bridge.") version ".tar.gz")) (sha256 (base32 - "1ydw42lsd572qwrfgws97n76hyvjdpanwrxm03lysnhfxkna1ssd")))) + "1icfrv8yihcb74as1gcgmp0wfpdq632q2zvbvqqvjms9cy87bswb")))) (build-system gnu-build-system) (native-inputs `(("flex" ,flex) ("bison" ,bison))) (home-page "http://www.infradead.org/~tgr/libnl/") @@ -929,6 +929,32 @@ configuration and monitoring interfaces.") ;; 'nl-addr-add.c'), so the result is GPLv2-only. (license gpl2))) +(define-public iw + (package + (name "iw") + (version "3.17") + (source (origin + (method url-fetch) + (uri (string-append + "https://www.kernel.org/pub/software/network/iw/iw-" + version ".tar.xz")) + (sha256 + (base32 + "14zsapqhivk0ws5z21y1ys2c2czi05mzk7bl2yb7qxcfrnsjx9j8")))) + (build-system gnu-build-system) + (native-inputs `(("pkg-config" ,pkg-config))) + (inputs `(("libnl" ,libnl))) + (arguments + `(#:make-flags (list (string-append "PREFIX=" (assoc-ref %outputs "out")) + "CC=gcc") + #:phases (alist-delete 'configure %standard-phases))) + (home-page "http://wireless.kernel.org/en/users/Documentation/iw") + (synopsis "Tool for configuring wireless devices") + (description + "iw is a new nl80211 based CLI configuration utility for wireless +devices. It replaces 'iwconfig', which is deprecated.") + (license isc))) + (define-public powertop (package (name "powertop") diff --git a/gnu/packages/patches/libcanberra-sound-theme-freedesktop.patch b/gnu/packages/patches/libcanberra-sound-theme-freedesktop.patch new file mode 100644 index 0000000000..ff998cbf76 --- /dev/null +++ b/gnu/packages/patches/libcanberra-sound-theme-freedesktop.patch @@ -0,0 +1,22 @@ +# We insert a hook called "@SOUND_THEME_DIRECTORY@" where, at build time, we +# insert the directory of the package "sound-theme-freedesktop" in the store. + +--- src/sound-theme-spec.c.orig 2015-01-11 13:13:29.520527358 +0100 ++++ src/sound-theme-spec.c 2015-01-11 14:27:23.035046849 +0100 +@@ -321,9 +321,13 @@ + const char *g; + + if (!(g = getenv("XDG_DATA_DIRS")) || *g == 0) +- return "/usr/local/share:/usr/share"; +- +- return g; ++ return "@SOUND_THEME_DIRECTORY@"; ++ else { ++ const char *stp = ":@SOUND_THEME_DIRECTORY@"; ++ size_t len = strlen(stp) + strlen(g) + 1; ++ char *g2 = (char*) malloc(len); ++ return strcat(strcpy(g2, g), stp); ++ } + } + + static int load_theme_dir(ca_theme_data *t, const char *name) { diff --git a/gnu/packages/pdf.scm b/gnu/packages/pdf.scm index 0f9098d8cb..02b55aca9b 100644 --- a/gnu/packages/pdf.scm +++ b/gnu/packages/pdf.scm @@ -37,6 +37,8 @@ #:use-module (gnu packages gtk) #:use-module (gnu packages lua) #:use-module (gnu packages curl) + #:use-module (gnu packages pcre) + #:use-module (gnu packages perl) #:use-module (srfi srfi-1)) (define-public poppler @@ -238,3 +240,43 @@ The library ships with a rudimentary X11 viewer, and a set of command line tools for batch rendering (pdfdraw), examining the file structure (pdfshow), and rewriting files (pdfclean).") (license license:agpl3+))) + +(define-public qpdf + (package + (name "qpdf") + (version "5.1.2") + (source (origin + (method url-fetch) + (uri (string-append "mirror://sourceforge/qpdf/qpdf-" + version ".tar.gz")) + (sha256 (base32 + "1zbvhrp0zjzbi6q2bnbxbg6399r47pq5gw3kspzph81j19fqvpg9")))) + (build-system gnu-build-system) + (arguments + '(#:phases (alist-cons-before + 'configure 'patch-paths + (lambda _ + (substitute* "make/libtool.mk" + (("SHELL=/bin/bash") + (string-append "SHELL=" (which "bash")))) + (substitute* (append + '("qtest/bin/qtest-driver") + (find-files "." "\\.test")) + (("/usr/bin/env") (which "env")))) + %standard-phases))) + (native-inputs + `(("pkg-config" ,pkg-config))) + (propagated-inputs + `(("pcre" ,pcre))) + (inputs + `(("zlib" ,zlib) + ("perl" ,perl))) + (synopsis "Command-line tools and library for transforming PDF files") + (description + "QPDF is a command-line program that does structural, content-preserving +transformations on PDF files. It could have been called something like +pdf-to-pdf. It includes support for merging and splitting PDFs and to +manipulate the list of pages in a PDF file. It is not a PDF viewer or a +program capable of converting PDF into other formats.") + (license license:clarified-artistic) + (home-page "http://qpdf.sourceforge.net/"))) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index 984ba7e1f4..2febd12ff7 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -58,14 +58,14 @@ (define-public ffmpeg (package (name "ffmpeg") - (version "2.4.3") + (version "2.5.3") (source (origin (method url-fetch) (uri (string-append "http://www.ffmpeg.org/releases/ffmpeg-" version ".tar.bz2")) (sha256 (base32 - "00p6qi7kwc2rv7h98bczrdssa7nbda3fpz7avjwl77jg1qy3wp6a")))) + "06j1cgw9h9ya5z8gpcf9v9zik3l4xz7sr4wshj06kznzz5z3sf4x")))) (build-system gnu-build-system) (inputs `(("fontconfig" ,fontconfig) @@ -199,14 +199,14 @@ audio/video codec library.") ;; We need this older ffmpeg because vlc-2.1.5 doesn't work with ffmpeg-2.4. (define-public ffmpeg-2.2 (package (inherit ffmpeg) - (version "2.2.10") + (version "2.2.11") (source (origin (method url-fetch) (uri (string-append "http://www.ffmpeg.org/releases/ffmpeg-" version ".tar.bz2")) (sha256 (base32 - "14d83ijp5lxdr6nl9rqhc4598jp020paxrg64r9ifxqhbigl0yqm")))))) + "06sli7xvihh97ss6a2mkdq4dcj3rg1w8zffrmjfc1hvyjxhc8f2r")))))) (define-public vlc (package diff --git a/gnu/packages/xdisorg.scm b/gnu/packages/xdisorg.scm index 2052f7b9be..b48563227c 100644 --- a/gnu/packages/xdisorg.scm +++ b/gnu/packages/xdisorg.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ #:use-module (gnu packages pkg-config) #:use-module (gnu packages glib) #:use-module (gnu packages perl) + #:use-module (gnu packages linux) #:use-module (gnu packages xorg)) ;; packages outside the x.org system proper @@ -359,3 +361,34 @@ invisible cursor. This allows you to see all the text in an xterm or xedit, for example. The human factors crowd would agree it should make things less distracting.") (license license:public-domain))) + +(define-public xlockmore + (package + (name "xlockmore") + (version "5.45") + (source (origin + (method url-fetch) + (uri (string-append "http://www.tux.org/~bagleyd/xlock/xlockmore-" + version "/xlockmore-" version ".tar.bz2")) + (sha256 + (base32 + "1xqm61bbfn5q056w57vp16gvai8nqpcw570ysxlm5h46nh6ai0bz")))) + (build-system gnu-build-system) + (arguments + '(#:configure-flags (list (string-append "--enable-appdefaultdir=" + (assoc-ref %outputs "out") + "/lib/X11/app-defaults")) + #:tests? #f)) ;no such thing as a test suite + (inputs + `(("libX11" ,libx11) + ("libXext" ,libxext) + ("libXt" ,libxt) + ("linux-pam" ,linux-pam))) + (home-page "http://www.tux.org/~bagleyd/xlockmore.html") + (synopsis "Screen locker for the X Window System") + (description + "XLockMore is a classic screen locker and screen saver for the +X Window System.") + (license (license:bsd-style #f "See xlock.c.") + ;; + GPLv2 in modes/glx/biof.c. + ))) diff --git a/gnu/packages/xlockmore.scm b/gnu/packages/xlockmore.scm deleted file mode 100644 index 1665849016..0000000000 --- a/gnu/packages/xlockmore.scm +++ /dev/null @@ -1,52 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 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 packages xlockmore) - #:use-module (guix packages) - #:use-module (guix download) - #:use-module (guix build-system gnu) - #:use-module (guix licenses) - #:use-module (gnu packages xorg) - #:use-module (gnu packages linux)) - -(define-public xlockmore - (package - (name "xlockmore") - (version "5.42") - (source (origin - (method url-fetch) - (uri (string-append "http://www.tux.org/~bagleyd/xlock/xlockmore-" - version "/xlockmore-" version ".tar.bz2")) - (sha256 - (base32 - "17xicps92ah9377zk65k9l1bmvzzj3bpxzzwxx21g9696l71gr0z")))) - (build-system gnu-build-system) - (arguments '(#:tests? #f)) ; no such thing as a test suite - (inputs - `(("libX11" ,libx11) - ("libXext" ,libxext) - ("libXt" ,libxt) - ("linux-pam" ,linux-pam))) - (home-page "http://www.tux.org/~bagleyd/xlockmore.html") - (synopsis "Screen locker for the X Window System") - (description - "XLockMore is a classic screen locker and screen saver for the -X Window System.") - (license (bsd-style #f "See xlock.c.") - ;; + GPLv2 in modes/glx/biof.c. - ))) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 95edba6e7c..402f5991a5 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -232,13 +232,7 @@ stopped before 'kill' is called." (define lset= (@ (srfi srfi-1) lset=)) - ;; When this happens, all the processes have been - ;; killed, including 'deco', so DMD-OUTPUT-PORT and - ;; thus CURRENT-OUTPUT-PORT are dangling. - (call-with-output-file "/dev/console" - (lambda (port) - (display "sending all processes the TERM signal\n" - port))) + (display "sending all processes the TERM signal\n") (if (null? omitted-pids) (begin diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 8091311879..7a90587136 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -34,15 +34,14 @@ ;; This build system is an extension of the 'gnu-build-system'. It ;; accomodates the needs of applications making use of glib or gtk+ (with "or" ;; to be interpreted in the mathematical sense). This is achieved by adding -;; two phases run after the 'install' phase: +;; three phases run after the 'install' phase: ;; ;; 'glib-or-gtk-wrap' phase: ;; -;; a) This phase looks for GSettings schemas by verifying the existence of -;; path "datadir/glib-2.0/schemas" in all input packages. If the path is -;; found in any package, then all programs in "out/bin" are wrapped in scripts -;; where the environment variable "XDG_DATA_DIRS" is set and points to the -;; list of found schemas directories. +;; a) This phase looks for GSettings schemas, GIO modules and theming data. +;; If any of these is found in any input package, then all programs in +;; "out/bin" are wrapped in scripts defining the nedessary environment +;; variables. ;; ;; b) Looks for the existence of "libdir/gtk-3.0" directories in all input ;; packages. If any is found, then the environment variable "GTK_PATH" is @@ -56,6 +55,11 @@ ;; exists and does not include a file named "gschemas.compiled", then ;; "glib-compile-schemas" is run in that directory. ;; +;; 'glib-or-gtk-icon-cache' phase: +;; +;; Looks for the existence of icon themes and, if no cache exists, generate +;; the "icon-theme.cache" file. +;; ;; Code: (define %default-modules @@ -76,15 +80,22 @@ (let ((module (resolve-interface '(gnu packages glib)))) (module-ref module 'glib))) +(define (default-gtk+) + "Return the default gtk+ package from which we use +\"gtk-update-icon-cache\"." + (let ((module (resolve-interface '(gnu packages gtk)))) + (module-ref module 'gtk+))) + (define* (lower name #:key source inputs native-inputs outputs system target - (glib (default-glib)) (implicit-inputs? #t) + (glib (default-glib)) (gtk+ (default-gtk+)) + (implicit-inputs? #t) (strip-binaries? #t) #:allow-other-keys #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:glib #:inputs #:native-inputs + '(#:source #:target #:glib #:gtk+ #:inputs #:native-inputs #:outputs #:implicit-inputs?)) (and (not target) ;XXX: no cross-compilation @@ -95,7 +106,8 @@ `(("source" ,source)) '()) ,@inputs)) - (build-inputs `(("glib:bin" ,glib) + (build-inputs `(("glib:bin" ,glib "bin") ; to compile schemas + ("gtk+" ,gtk+) ; to generate icon cache ,@(if implicit-inputs? (standard-packages) '()) diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index 9351a70a0e..a404a84f3f 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -22,6 +22,7 @@ #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -41,6 +42,9 @@ (fold (lambda (s p) (or (string-ci=? s directory) p)) #f directories-list)) +;; We do not include $HOME/.guix-profile/gtk-v.0 (v=2 or 3) because we do not +;; want to mix gtk+-2 and gtk+-3 modules. See +;; https://developer.gnome.org/gtk3/stable/gtk-running.html (define (gtk-module-directories inputs) "Check for the existence of \"libdir/gtk-v.0\" in INPUTS. Return a list with all found directories." @@ -64,20 +68,60 @@ with all found directories." prev))))) (fold gtk-module '() inputs))) -(define (schemas-directories inputs) - "Check for the existence of \"datadir/glib-2.0/schemas\" in INPUTS. Return -a list with all found directories." - (define (glib-schemas input previous) +;; See +;; http://www.freedesktop.org/wiki/DesktopThemeSpec +;; http://freedesktop.org/wiki/Specifications/sound-theme-spec +;; http://freedesktop.org/wiki/Specifications/icon-theme-spec +;; +;; Currently desktop themes are not well supported and do not honor +;; XDG_DATA_DIRS. One example is evince which only looks for desktop themes +;; in $HOME/.themes (for backward compatibility) and in XDG_DATA_HOME (which +;; defaults to $HOME/.local/share). One way to handle these applications +;; appears to be by making $HOME/.themes a symlink to +;; $HOME/.guix-profile/share/themes. +(define (data-directories inputs) + "Check for the existence of \"$datadir/glib-2.0/schemas\" or XDG themes data +in INPUTS. Return a list with all found directories." + (define (data-directory input previous) (let* ((in (match input ((_ . dir) dir) (_ ""))) (datadir (string-append in "/share"))) - (if (and (subdirectory-exists? datadir "/glib-2.0/schemas") + (if (and (or (subdirectory-exists? datadir "/glib-2.0/schemas") + (subdirectory-exists? datadir "/sounds") + (subdirectory-exists? datadir "/themes") + (subdirectory-exists? datadir "/cursors") + (subdirectory-exists? datadir "/wallpapers") + (subdirectory-exists? datadir "/icons")) (not (directory-included? datadir previous))) (cons datadir previous) previous))) - (fold glib-schemas '() inputs)) + (fold data-directory '() inputs)) + +;; All GIO modules are expected to be installed in GLib's $libdir/gio/modules +;; directory. That directory has to include a file called giomodule.cache +;; listing all available modules. GIO can be made aware of modules in other +;; directories with the help of the environment variable GIO_EXTRA_MODULES. +;; The official GIO documentation states that this environment variable should +;; only be used for testing and not in a production environment. However, it +;; appears that there is no other way of specifying multiple modules +;; directories (NIXOS also does use this variable). See +;; https://developer.gnome.org/gio/stable/running-gio-apps.html +(define (gio-module-directories inputs) + "Check for the existence of \"$libdir/gio/modules\" in the INPUTS and +returns a list with all found directories." + (define (gio-module-directory input previous) + (let* ((in (match input + ((_ . dir) dir) + (_ ""))) + (gio-mod-dir (string-append in "/lib/gio/modules"))) + (if (and (directory-exists? gio-mod-dir) + (not (directory-included? gio-mod-dir previous))) + (cons gio-mod-dir previous) + previous))) + + (fold gio-module-directory '() inputs)) (define* (wrap-all-programs #:key inputs outputs (glib-or-gtk-wrap-excluded-outputs '()) @@ -96,27 +140,57 @@ add a dependency of that output on GLib and GTK+." (unless (member output glib-or-gtk-wrap-excluded-outputs) (let* ((bindir (string-append directory "/bin")) (bin-list (find-files bindir ".*")) - (schemas (schemas-directories + (datadirs (data-directories (alist-cons output directory inputs))) (gtk-mod-dirs (gtk-module-directories (alist-cons output directory inputs))) - (schemas-env-var - (if (not (null? schemas)) - `("XDG_DATA_DIRS" ":" prefix ,schemas) + (gio-mod-dirs (gio-module-directories + (alist-cons output directory inputs))) + (data-env-var + (if (not (null? datadirs)) + `("XDG_DATA_DIRS" ":" prefix ,datadirs) #f)) (gtk-mod-env-var (if (not (null? gtk-mod-dirs)) `("GTK_PATH" ":" prefix ,gtk-mod-dirs) + #f)) + (gio-mod-env-var + (if (not (null? gio-mod-dirs)) + `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs) #f))) (cond - ((and schemas-env-var gtk-mod-env-var) - (for-each (cut wrap-program <> schemas-env-var gtk-mod-env-var) + ((and data-env-var gtk-mod-env-var gio-mod-env-var) + (for-each (cut wrap-program <> + data-env-var + gtk-mod-env-var + gio-mod-env-var) bin-list)) - (schemas-env-var - (for-each (cut wrap-program <> schemas-env-var) + ((and data-env-var gtk-mod-env-var (not gio-mod-env-var)) + (for-each (cut wrap-program <> + data-env-var + gtk-mod-env-var) bin-list)) - (gtk-mod-env-var - (for-each (cut wrap-program <> gtk-mod-env-var) + ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var) + (for-each (cut wrap-program <> + data-env-var + gio-mod-env-var) + bin-list)) + ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var) + (for-each (cut wrap-program <> + gio-mod-env-var + gtk-mod-env-var) + bin-list)) + ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var)) + (for-each (cut wrap-program <> + data-env-var) + bin-list)) + ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var)) + (for-each (cut wrap-program <> + gtk-mod-env-var) + bin-list)) + ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var) + (for-each (cut wrap-program <> + gio-mod-env-var) bin-list)))))))) (for-each handle-output outputs) @@ -136,12 +210,41 @@ if needed." #t)))) outputs)) +(define* (generate-icon-cache #:key outputs #:allow-other-keys) + "Implement phase \"glib-or-gtk-icon-cache\": generate icon cache if +needed." + (every (match-lambda + ((output . directory) + (let ((iconsdir (string-append directory + "/share/icons"))) + (when (file-exists? iconsdir) + (with-directory-excursion iconsdir + (for-each + (lambda (dir) + (unless (file-exists? + (string-append iconsdir "/" dir "/" + "icon-theme.cache")) + (system* "gtk-update-icon-cache" + "--ignore-theme-index" + (string-append iconsdir "/" dir)))) + (scandir "." + (lambda (name) + (and + (not (equal? name ".")) + (not (equal? name "..")) + (equal? 'directory + (stat:type (stat name))))))))) + #t))) + outputs)) + (define %standard-phases (alist-cons-after 'install 'glib-or-gtk-wrap wrap-all-programs (alist-cons-after - 'install 'glib-or-gtk-compile-schemas compile-glib-schemas - gnu:%standard-phases))) + 'install 'glib-or-gtk-icon-cache generate-icon-cache + (alist-cons-after + 'install 'glib-or-gtk-compile-schemas compile-glib-schemas + gnu:%standard-phases)))) (define* (glib-or-gtk-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/derivations.scm b/guix/derivations.scm index ec438e833c..b48e7e604d 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -31,6 +31,7 @@ #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix records) + #:use-module (guix sets) #:export (<derivation> derivation? derivation-outputs @@ -162,16 +163,18 @@ download with a fixed hash (aka. `fetchurl')." (define (derivation-prerequisites drv) "Return the list of derivation-inputs required to build DRV, recursively." - (let loop ((drv drv) - (result '())) - (let ((inputs (remove (cut member <> result) ; XXX: quadratic + (let loop ((drv drv) + (result '()) + (input-set (set))) + (let ((inputs (remove (cut set-contains? input-set <>) (derivation-inputs drv)))) - (fold loop - (append inputs result) - (map (lambda (i) - (call-with-input-file (derivation-input-path i) - read-derivation)) - inputs))))) + (fold2 loop + (append inputs result) + (fold set-insert input-set inputs) + (map (lambda (i) + (call-with-input-file (derivation-input-path i) + read-derivation)) + inputs))))) (define (offloadable-derivation? drv) "Return true if DRV can be offloaded, false otherwise." @@ -214,8 +217,8 @@ substituter many times." (append self deps result))) '() drv))) - (subst (substitutable-paths store paths))) - (cut member <> subst))) + (subst (list->set (substitutable-paths store paths)))) + (cut set-contains? subst <>))) (define* (derivation-prerequisites-to-build store drv #:key diff --git a/guix/gexp.scm b/guix/gexp.scm index 78e11f5850..d13e1c46da 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +33,8 @@ gexp? gexp->derivation gexp->file - gexp->script)) + gexp->script + text-file*)) ;;; Commentary: ;;; @@ -522,6 +523,18 @@ its search path." (write '(ungexp exp) port)))) #:local-build? #t)) +(define* (text-file* name #:rest text) + "Return as a monadic value a derivation that builds a text file containing +all of TEXT. TEXT may list, in addition to strings, packages, derivations, +and store file names; the resulting store file holds references to all these." + (define builder + (gexp (call-with-output-file (ungexp output "out") + (lambda (port) + (display (string-append (ungexp-splicing text)) port))))) + + (gexp->derivation name builder)) + + ;;; ;;; Syntactic sugar. diff --git a/guix/monads.scm b/guix/monads.scm index 65683e65de..20fee79602 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,6 @@ store-lift run-with-store text-file - text-file* interned-file package-file origin->derivation @@ -357,56 +356,6 @@ containing TEXT, a string." (lambda (store) (add-text-to-store store name text '()))) -(define* (text-file* name #:rest text) - "Return as a monadic value a derivation that builds a text file containing -all of TEXT. TEXT may list, in addition to strings, packages, derivations, -and store file names; the resulting store file holds references to all these." - (define inputs - ;; Transform packages and derivations from TEXT into a valid input list. - (filter-map (match-lambda - ((? package? p) `("x" ,p)) - ((? derivation? d) `("x" ,d)) - ((x ...) `("x" ,@x)) - ((? string? s) - (and (direct-store-path? s) `("x" ,s))) - (x x)) - text)) - - (define (computed-text text inputs) - ;; Using the lowered INPUTS, return TEXT with derivations replaced with - ;; their output file name. - (define (real-string? s) - (and (string? s) (not (direct-store-path? s)))) - - (let loop ((inputs inputs) - (text text) - (result '())) - (match text - (() - (string-concatenate-reverse result)) - (((? real-string? head) rest ...) - (loop inputs rest (cons head result))) - ((_ rest ...) - (match inputs - (((_ (? derivation? drv) sub-drv ...) inputs ...) - (loop inputs rest - (cons (apply derivation->output-path drv - sub-drv) - result))) - (((_ file) inputs ...) - ;; FILE is the result of 'add-text-to-store' or so. - (loop inputs rest (cons file result)))))))) - - (define (builder inputs) - `(call-with-output-file (assoc-ref %outputs "out") - (lambda (port) - (display ,(computed-text text inputs) port)))) - - ;; TODO: Rewrite using 'gexp->derivation'. - (mlet %store-monad ((inputs (lower-inputs inputs))) - (derivation-expression name (builder inputs) - #:inputs inputs))) - (define* (interned-file file #:optional name #:key (recursive? #t)) "Return the name of FILE once interned in the store. Use NAME as its store @@ -440,26 +389,6 @@ cross-compilation target triplet." (string-append out "/" file) out)))) -(define (lower-inputs inputs) - "Turn any package from INPUTS into a derivation; return the corresponding -input list as a monadic value." - ;; XXX: This procedure is bound to disappear with 'derivation-expression'. - (with-monad %store-monad - (sequence %store-monad - (map (match-lambda - ((name (? package? package) sub-drv ...) - (mlet %store-monad ((drv (package->derivation package))) - (return `(,name ,drv ,@sub-drv)))) - ((name (? string? file)) - (return `(,name ,file))) - (tuple - (return tuple))) - inputs)))) - -(define derivation-expression - ;; XXX: This procedure is superseded by 'gexp->derivation'. - (store-lift build-expression->derivation)) - (define package->derivation (store-lift package-derivation)) diff --git a/guix/sets.scm b/guix/sets.scm new file mode 100644 index 0000000000..017b79ca31 --- /dev/null +++ b/guix/sets.scm @@ -0,0 +1,116 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 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 sets) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:export (set + setq + set? + set-insert + set-union + set-contains? + set->list + list->set + list->setq)) + +;;; Commentary: +;;; +;;; A simple (simplistic?) implementation of unordered persistent sets based +;;; on vhashes that seems to be good enough so far. +;;; +;;; Another option would be to use "bounded balance trees" (Adams 1992) as +;;; implemented by Ian Price in 'pfds', which has faster union etc. but needs +;;; an order on the objects of the set. +;;; +;;; Code: + +(define-record-type <set> + (%make-set vhash insert ref) + set? + (vhash set-vhash) + (insert set-insert-proc) + (ref set-ref)) + +(define %insert + (cut vhash-cons <> #t <>)) +(define %insertq + (cut vhash-consq <> #t <>)) + +(define (set . args) + "Return a set containing the ARGS, compared as per 'equal?'." + (list->set args)) + +(define (setq . args) + "Return a set containing the ARGS, compared as per 'eq?'." + (list->setq args)) + +(define (list->set lst) + "Return a set with the elements taken from LST. Elements of the set will be +compared with 'equal?'." + (%make-set (fold %insert vlist-null lst) + %insert + vhash-assoc)) + +(define (list->setq lst) + "Return a set with the elements taken from LST. Elements of the set will be +compared with 'eq?'." + (%make-set (fold %insertq vlist-null lst) + %insertq + vhash-assq)) + +(define-inlinable (set-contains? set value) + "Return #t if VALUE is a member of SET." + (->bool ((set-ref set) value (set-vhash set)))) + +(define (set-insert value set) + "Insert VALUE into SET." + (if (set-contains? set value) + set + (let ((vhash ((set-insert-proc set) value (set-vhash set)))) + (%make-set vhash (set-insert-proc set) (set-ref set))))) + +(define-inlinable (set-size set) + "Return the number of elements in SET." + (vlist-length (set-vhash set))) + +(define (set-union set1 set2) + "Return the union of SET1 and SET2. Warning: this is linear in the number +of elements of the smallest." + (unless (eq? (set-insert-proc set1) (set-insert-proc set2)) + (error "set-union: incompatible sets")) + + (let* ((small (if (> (set-size set1) (set-size set2)) + set2 set1)) + (large (if (eq? small set1) set2 set1))) + (vlist-fold (match-lambda* + (((item . _) result) + (set-insert item result))) + large + (set-vhash small)))) + +(define (set->list set) + "Return the list of elements of SET." + (map (match-lambda + ((key . _) key)) + (vlist->list (set-vhash set)))) + +;;; sets.scm ends here diff --git a/tests/gexp.scm b/tests/gexp.scm index ea4df48403..d80f14344d 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -421,6 +421,30 @@ (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) +(test-assert "text-file*" + (let ((references (store-lift references))) + (run-with-store %store + (mlet* %store-monad + ((drv (package->derivation %bootstrap-guile)) + (guile -> (derivation->output-path drv)) + (file (text-file "bar" "This is bar.")) + (text (text-file* "foo" + %bootstrap-guile "/bin/guile " + `(,%bootstrap-guile "out") "/bin/guile " + drv "/bin/guile " + file)) + (done (built-derivations (list text))) + (out -> (derivation->output-path text)) + (refs (references out))) + ;; Make sure we get the right references and the right content. + (return (and (lset= string=? refs (list guile file)) + (equal? (call-with-input-file out get-string-all) + (string-append guile "/bin/guile " + guile "/bin/guile " + guile "/bin/guile " + file))))) + #:guile-for-build (package-derivation %store %bootstrap-guile)))) + (test-assert "printer" (string-match "^#<gexp \\(string-append .*#<package coreutils.*\ \"/bin/uname\"\\) [[:xdigit:]]+>$" diff --git a/tests/lint.scm b/tests/lint.scm index c6931329d6..27be5598de 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,9 +75,20 @@ (quit #t) ;exit the server thread (values))) +;; Mutex and condition variable to synchronize with the HTTP server. +(define %http-server-lock (make-mutex)) +(define %http-server-ready (make-condition-variable)) + +(define (http-open . args) + "Start listening for HTTP requests and signal %HTTP-SERVER-READY." + (with-mutex %http-server-lock + (let ((result (apply (@@ (web server http) http-open) args))) + (signal-condition-variable %http-server-ready) + result))) + (define-server-impl stub-http-server ;; Stripped-down version of Guile's built-in HTTP server. - (@@ (web server http) http-open) + http-open (@@ (web server http) http-read) http-write (@@ (web server http) http-close)) @@ -97,9 +108,11 @@ requests." `(#:socket ,%http-server-socket))) (const #t))) - (let* ((server (make-thread server-body))) - ;; Normally SERVER exits automatically once it has received a request. - (thunk))) + (with-mutex %http-server-lock + (let ((server (make-thread server-body))) + (wait-condition-variable %http-server-ready %http-server-lock) + ;; Normally SERVER exits automatically once it has received a request. + (thunk)))) (define-syntax-rule (with-http-server code body ...) (call-with-http-server code (lambda () body ...))) diff --git a/tests/monads.scm b/tests/monads.scm index 6e3dd00f72..9c3cdd20a7 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -156,51 +156,6 @@ (call-with-input-file b get-string-all)))) #:guile-for-build (package-derivation %store %bootstrap-guile))) -(define derivation-expression - (@@ (guix monads) derivation-expression)) - -(test-assert "mlet* + derivation-expression" - (run-with-store %store - (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile")) - (gdrv (package->derivation %bootstrap-guile)) - (exp -> `(let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (symlink ,guile - (string-append out "/guile-rocks")))) - (drv (derivation-expression "rocks" exp - #:inputs - `(("g" ,gdrv)))) - (out -> (derivation->output-path drv)) - (built? (built-derivations (list drv)))) - (return (and built? - (equal? guile - (readlink (string-append out "/guile-rocks")))))) - #:guile-for-build (package-derivation %store %bootstrap-guile))) - -(test-assert "text-file*" - (let ((references (store-lift references))) - (run-with-store %store - (mlet* %store-monad - ((drv (package->derivation %bootstrap-guile)) - (guile -> (derivation->output-path drv)) - (file (text-file "bar" "This is bar.")) - (text (text-file* "foo" - %bootstrap-guile "/bin/guile " - `(,%bootstrap-guile "out") "/bin/guile " - drv "/bin/guile " - file)) - (done (built-derivations (list text))) - (out -> (derivation->output-path text)) - (refs (references out))) - ;; Make sure we get the right references and the right content. - (return (and (lset= string=? refs (list guile file)) - (equal? (call-with-input-file out get-string-all) - (string-append guile "/bin/guile " - guile "/bin/guile " - guile "/bin/guile " - file))))) - #:guile-for-build (package-derivation %store %bootstrap-guile)))) - (test-assert "mapm" (every (lambda (monad run) (with-monad monad diff --git a/tests/sets.scm b/tests/sets.scm new file mode 100644 index 0000000000..0a89591765 --- /dev/null +++ b/tests/sets.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 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 (test-sets) + #:use-module (guix sets) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64)) + + +(test-begin "sets") + +(test-assert "set-contains?" + (let* ((lst (iota 123)) + (set (list->set lst))) + (and (every (cut set-contains? set <>) + lst) + (not (set-contains? set -1))))) + +(test-assert "set->list" + (let* ((lst (iota 123)) + (set (list->set lst))) + (lset= = lst (set->list set)))) + +(test-assert "set-union" + (let* ((a (list 'a)) + (b (list 'b)) + (s1 (setq a)) + (s2 (setq b)) + (s3 (set-union s1 s2))) + (and (set-contains? s3 a) + (set-contains? s3 b)))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |