diff options
| -rw-r--r-- | build-aux/hydra/gnu-system.scm | 18 | ||||
| -rw-r--r-- | doc/guix.texi | 11 | ||||
| -rw-r--r-- | gnu/services/avahi.scm | 3 | ||||
| -rw-r--r-- | gnu/services/base.scm | 3 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 3 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 4 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 3 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 5 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 3 | ||||
| -rw-r--r-- | gnu/system/install.scm | 3 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 3 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 3 | ||||
| -rw-r--r-- | guix/derivations.scm | 67 | ||||
| -rw-r--r-- | guix/download.scm | 4 | ||||
| -rw-r--r-- | guix/gexp.scm | 7 | ||||
| -rw-r--r-- | guix/git-download.scm | 3 | ||||
| -rw-r--r-- | guix/monad-repl.scm | 26 | ||||
| -rw-r--r-- | guix/monads.scm | 137 | ||||
| -rw-r--r-- | guix/packages.scm | 58 | ||||
| -rw-r--r-- | guix/profiles.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 28 | ||||
| -rw-r--r-- | guix/store.scm | 86 | ||||
| -rw-r--r-- | guix/svn-download.scm | 3 | ||||
| -rw-r--r-- | tests/monads.scm | 3 |
27 files changed, 285 insertions, 228 deletions
diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index f62c9cb11d..cfef7dc425 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -147,14 +147,18 @@ system.") (if (member system '("x86_64-linux" "i686-linux")) (list (->job 'qemu-image (run-with-store store - (system-qemu-image (demo-os) - #:disk-image-size - (* 1400 MiB)))) ; 1.4 GiB + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (system-qemu-image (demo-os) + #:disk-image-size + (* 1400 MiB))))) ; 1.4 GiB (->job 'usb-image (run-with-store store - (system-disk-image installation-os - #:disk-image-size - (* 800 MiB))))) + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (system-disk-image installation-os + #:disk-image-size + (* 800 MiB)))))) '())) (define job-name diff --git a/doc/guix.texi b/doc/guix.texi index 5f25583906..c052804a45 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2194,8 +2194,8 @@ scheme@@(guile-user)> Note that non-monadic values cannot be returned in the @code{store-monad} REPL. -The main syntactic forms to deal with monads in general are described -below. +The main syntactic forms to deal with monads in general are provided by +the @code{(guix monads)} module and are described below. @deffn {Scheme Syntax} with-monad @var{monad} @var{body} ... Evaluate any @code{>>=} or @code{return} forms in @var{body} as being @@ -2235,8 +2235,8 @@ monadic expressions are ignored. In that sense, it is analogous to @code{begin}, but applied to monadic expressions. @end deffn -The interface to the store monad provided by @code{(guix monads)} is as -follows. +The main interface to the store monad, provided by the @code{(guix +store)} module, is as follows. @defvr {Scheme Variable} %store-monad The store monad. Values in the store monad encapsulate accesses to the @@ -2278,6 +2278,9 @@ The example below adds a file to the store, under two different names: @end deffn +The @code{(guix packages)} module exports the following package-related +monadic procedures: + @deffn {Monadic Procedure} package-file @var{package} [@var{file}] @ [#:system (%current-system)] [#:target #f] @ [#:output "out"] Return as a monadic diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 48a2c75927..89478cb997 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.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. ;;; @@ -21,6 +21,7 @@ #:use-module (gnu system shadow) #:use-module (gnu packages avahi) #:use-module (guix monads) + #:use-module (guix store) #:use-module (guix gexp) #:export (avahi-service)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3a4be44330..d55eb3a5f9 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -17,8 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services base) - #:use-module ((guix store) - #:select (%store-prefix)) + #:use-module (guix store) #:use-module (gnu services) #:use-module (gnu services networking) #:use-module (gnu system shadow) ; 'user-account', etc. diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index 5da7f14605..d97c54cc5d 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.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. ;;; @@ -21,6 +21,7 @@ #:use-module (gnu system shadow) #:use-module (gnu packages glib) #:use-module (guix monads) + #:use-module (guix store) #:use-module (guix gexp) #:export (dbus-service)) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 35b6b384c1..4bf76e01ec 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.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. ;;; @@ -18,7 +18,9 @@ (define-module (gnu services dmd) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix derivations) ;imported-modules, etc. #:use-module (gnu services) #:use-module (ice-9 match) #:use-module (srfi srfi-1) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index db9be8cfbd..f0c3538e0b 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.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. ;;; @@ -25,6 +25,7 @@ #:use-module (gnu packages messaging) #:use-module (gnu packages ntp) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) #:use-module (srfi srfi-26) #:export (%facebook-host-aliases diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 2b52c777b7..8868e4fcdb 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.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. ;;; @@ -18,10 +18,11 @@ (define-module (gnu services ssh) #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (gnu services) #:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu packages lsh) - #:use-module (guix monads) #:export (lsh-service)) ;;; Commentary: diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index b32bb8674c..6820456698 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.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. ;;; @@ -30,6 +30,7 @@ #:use-module (gnu packages admin) #:use-module (gnu packages bash) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) #:use-module (srfi srfi-1) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index ab3fe42ae1..35462fff75 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.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. ;;; @@ -19,6 +19,7 @@ (define-module (gnu system install) #:use-module (gnu) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) #:use-module ((guix store) #:select (%store-prefix)) #:use-module (gnu packages admin) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index ee6ce48828..e72d050e96 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.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. ;;; @@ -18,6 +18,7 @@ (define-module (gnu system linux-initrd) #:use-module (guix monads) + #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix utils) #:use-module ((guix store) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index b4ba0060bd..4a9580a672 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.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. ;;; @@ -19,6 +19,7 @@ (define-module (gnu system shadow) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) #:use-module ((gnu system file-systems) #:select (%tty-gid)) diff --git a/guix/derivations.scm b/guix/derivations.scm index b48e7e604d..4c34fcb4b8 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -28,6 +28,7 @@ #:use-module (ice-9 vlist) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix monads) #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix records) @@ -84,11 +85,16 @@ map-derivation - %guile-for-build + built-derivations imported-modules compiled-modules + build-expression->derivation imported-files) + + ;; Re-export it from here for backward compatibility. + #:re-export (%guile-for-build) + #:replace (build-derivations)) ;;; @@ -895,11 +901,6 @@ recursively." ;;; Guile-based builders. ;;; -(define %guile-for-build - ;; The derivation of the Guile to be used within the build environment, - ;; when using `build-expression->derivation'. - (make-parameter #f)) - (define (parent-directories file-name) "Return the list of parent dirs of FILE-NAME, in the order in which an `mkdir -p' implementation would make them." @@ -956,11 +957,11 @@ system, imported, and appears under FINAL-PATH in the resulting store path." ;; up looking for the same files over and over again. (memoize search-path)) -(define* (imported-modules store modules - #:key (name "module-import") - (system (%current-system)) - (guile (%guile-for-build)) - (module-path %load-path)) +(define* (%imported-modules store modules + #:key (name "module-import") + (system (%current-system)) + (guile (%guile-for-build)) + (module-path %load-path)) "Return a derivation that contains the source files of MODULES, a list of module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH search path." @@ -975,18 +976,18 @@ search path." (imported-files store files #:name name #:system system #:guile guile))) -(define* (compiled-modules store modules - #:key (name "module-import-compiled") - (system (%current-system)) - (guile (%guile-for-build)) - (module-path %load-path)) +(define* (%compiled-modules store modules + #:key (name "module-import-compiled") + (system (%current-system)) + (guile (%guile-for-build)) + (module-path %load-path)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." - (let* ((module-drv (imported-modules store modules - #:system system - #:guile guile - #:module-path module-path)) + (let* ((module-drv (%imported-modules store modules + #:system system + #:guile guile + #:module-path module-path)) (module-dir (derivation->output-path module-drv)) (files (map (lambda (m) (let ((f (string-join (map symbol->string m) @@ -1218,15 +1219,15 @@ ALLOWED-REFERENCES, and LOCAL-BUILD?." (filter-map source-path inputs))) (mod-drv (and (pair? modules) - (imported-modules store modules - #:guile guile-drv - #:system system))) + (%imported-modules store modules + #:guile guile-drv + #:system system))) (mod-dir (and mod-drv (derivation->output-path mod-drv))) (go-drv (and (pair? modules) - (compiled-modules store modules - #:guile guile-drv - #:system system))) + (%compiled-modules store modules + #:guile guile-drv + #:system system))) (go-dir (and go-drv (derivation->output-path go-drv)))) (derivation store name guile @@ -1255,3 +1256,17 @@ ALLOWED-REFERENCES, and LOCAL-BUILD?." #:references-graphs references-graphs #:allowed-references allowed-references #:local-build? local-build?))) + + +;;; +;;; Monadic interface. +;;; + +(define built-derivations + (store-lift build-derivations)) + +(define imported-modules + (store-lift %imported-modules)) + +(define compiled-modules + (store-lift %compiled-modules)) diff --git a/guix/download.scm b/guix/download.scm index 4c111dd2b5..035d604aa7 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -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, 2014 Andreas Enge <andreas@enge.fr> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,7 @@ #:use-module (ice-9 match) #:use-module (guix derivations) #:use-module (guix packages) - #:use-module ((guix store) #:select (derivation-path? add-to-store)) + #:use-module (guix store) #:use-module ((guix build download) #:prefix build:) #:use-module (guix monads) #:use-module (guix gexp) diff --git a/guix/gexp.scm b/guix/gexp.scm index d13e1c46da..4e8f91df1d 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -17,12 +17,9 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix gexp) - #:use-module ((guix store) - #:select (direct-store-path?)) + #:use-module (guix store) #:use-module (guix monads) - #:use-module ((guix derivations) - #:select (derivation? derivation->output-path - %guile-for-build derivation)) + #:use-module (guix derivations) #:use-module (guix packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) diff --git a/guix/git-download.scm b/guix/git-download.scm index 94b118a7b9..490d8c319a 100644 --- a/guix/git-download.scm +++ b/guix/git-download.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. ;;; @@ -18,6 +18,7 @@ (define-module (guix git-download) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) #:use-module (guix records) #:use-module (guix packages) diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm index 5242f5448b..ebd9151065 100644 --- a/guix/monad-repl.scm +++ b/guix/monad-repl.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. ;;; @@ -19,6 +19,8 @@ (define-module (guix monad-repl) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix utils) + #:use-module (guix packages) #:use-module (ice-9 pretty-print) #:use-module (system repl repl) #:use-module (system repl common) @@ -54,20 +56,30 @@ #:make-default-environment (language-make-default-environment scheme)))) +(define* (default-guile-derivation store #:optional (system (%current-system))) + "Return the derivation of the default " + (package-derivation store (default-guile) system)) + (define (store-monad-language) "Return a compiler language for the store monad." - (let ((store (open-connection))) + (let* ((store (open-connection)) + (guile (or (%guile-for-build) + (default-guile-derivation store)))) (monad-language %store-monad - (cut run-with-store store <>) + (cut run-with-store store <> + #:guile-for-build guile) 'store-monad))) (define-meta-command ((run-in-store guix) repl (form)) "run-in-store EXP Run EXP through the store monad." - (let ((value (with-store store - (run-with-store store (repl-eval repl form))))) - (run-hook before-print-hook value) - (pretty-print value))) + (with-store store + (let* ((guile (or (%guile-for-build) + (default-guile-derivation store))) + (value (run-with-store store (repl-eval repl form) + #:guile-for-build guile))) + (run-hook before-print-hook value) + (pretty-print value)))) (define-meta-command ((enter-store-monad guix) repl) "enter-store-monad diff --git a/guix/monads.scm b/guix/monads.scm index 20fee79602..7fec3d5168 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -17,9 +17,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix monads) - #:use-module (guix store) - #:use-module (guix derivations) - #:use-module (guix packages) #:use-module ((system syntax) #:select (syntax-local-binding)) #:use-module (ice-9 match) @@ -49,22 +46,7 @@ anym ;; Concrete monads. - %identity-monad - - %store-monad - store-bind - store-return - store-lift - run-with-store - text-file - interned-file - package-file - origin->derivation - package->derivation - package->cross-derivation - built-derivations) - #:replace (imported-modules - compiled-modules)) + %identity-monad)) ;;; Commentary: ;;; @@ -309,121 +291,4 @@ lifted in MONAD, for which PROC returns true." (bind identity-bind) (return identity-return)) - -;;; -;;; Store monad. -;;; - -;; return:: a -> StoreM a -(define-inlinable (store-return value) - "Return VALUE from a monadic function." - ;; The monadic value is just this. - (lambda (store) - value)) - -;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b -(define-inlinable (store-bind mvalue mproc) - "Bind MVALUE in MPROC." - (lambda (store) - (let* ((value (mvalue store)) - (mresult (mproc value))) - (mresult store)))) - -(define-monad %store-monad - (bind store-bind) - (return store-return)) - - -(define (store-lift proc) - "Lift PROC, a procedure whose first argument is a connection to the store, -in the store monad." - (define result - (lambda args - (lambda (store) - (apply proc store args)))) - - (set-object-property! result 'documentation - (procedure-property proc 'documentation)) - result) - -;;; -;;; Store monad operators. -;;; - -(define* (text-file name text) - "Return as a monadic value the absolute file name in the store of the file -containing TEXT, a string." - (lambda (store) - (add-text-to-store store name text '()))) - -(define* (interned-file file #:optional name - #:key (recursive? #t)) - "Return the name of FILE once interned in the store. Use NAME as its store -name, or the basename of FILE if NAME is omitted. - -When RECURSIVE? is true, the contents of FILE are added recursively; if FILE -designates a flat file and RECURSIVE? is true, its contents are added, and its -permission bits are kept." - (lambda (store) - (add-to-store store (or name (basename file)) - recursive? "sha256" file))) - -(define* (package-file package - #:optional file - #:key - system (output "out") target) - "Return as a monadic value the absolute file name of FILE within the -OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the -OUTPUT directory of PACKAGE. When TARGET is true, use it as a -cross-compilation target triplet." - (lambda (store) - (define compute-derivation - (if target - (cut package-cross-derivation <> <> target <>) - package-derivation)) - - (let* ((system (or system (%current-system))) - (drv (compute-derivation store package system)) - (out (derivation->output-path drv output))) - (if file - (string-append out "/" file) - out)))) - -(define package->derivation - (store-lift package-derivation)) - -(define package->cross-derivation - (store-lift package-cross-derivation)) - -(define origin->derivation - (store-lift package-source-derivation)) - -(define imported-modules - (store-lift (@ (guix derivations) imported-modules))) - -(define compiled-modules - (store-lift (@ (guix derivations) compiled-modules))) - -(define built-derivations - (store-lift build-derivations)) - -(define* (run-with-store store mval - #:key - (guile-for-build (%guile-for-build)) - (system (%current-system))) - "Run MVAL, a monadic value in the store monad, in STORE, an open store -connection." - (define (default-guile) - ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) - ;; modules directly, to avoid circular dependencies, hence this hack. - (module-ref (resolve-interface '(gnu packages commencement)) - 'guile-final)) - - (parameterize ((%guile-for-build (or guile-for-build - (package-derivation store - (default-guile) - system))) - (%current-system system)) - (mval store))) - ;;; monads.scm end here diff --git a/guix/packages.scm b/guix/packages.scm index 2a9a55e12f..909aa6d90d 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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 © 2014 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix records) #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix derivations) #:use-module (guix build-system) @@ -108,7 +109,15 @@ bag-transitive-inputs bag-transitive-host-inputs bag-transitive-build-inputs - bag-transitive-target-inputs)) + bag-transitive-target-inputs + + default-guile + + set-guile-for-build + package-file + package->derivation + package->cross-derivation + origin->derivation)) ;;; Commentary: ;;; @@ -317,7 +326,8 @@ corresponds to the arguments expected by `set-path-environment-variable'." ("patch" ,(ref '(gnu packages base) 'patch))))) (define (default-guile) - "Return the default Guile package for SYSTEM." + "Return the default Guile package used to run the build code of +derivations." (let ((distro (resolve-interface '(gnu packages commencement)))) (module-ref distro 'guile-final))) @@ -899,3 +909,45 @@ symbolic output name, such as \"out\". Note that this procedure calls `package-derivation', which is costly." (let ((drv (package-derivation store package system))) (derivation->output-path drv output))) + + +;;; +;;; Monadic interface. +;;; + +(define (set-guile-for-build guile) + "This monadic procedure changes the Guile currently used to run the build +code of derivations to GUILE, a package object." + (lambda (store) + (let ((guile (package-derivation store guile))) + (%guile-for-build guile)))) + +(define* (package-file package + #:optional file + #:key + system (output "out") target) + "Return as a monadic value the absolute file name of FILE within the +OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the +OUTPUT directory of PACKAGE. When TARGET is true, use it as a +cross-compilation target triplet." + (lambda (store) + (define compute-derivation + (if target + (cut package-cross-derivation <> <> target <>) + package-derivation)) + + (let* ((system (or system (%current-system))) + (drv (compute-derivation store package system)) + (out (derivation->output-path drv output))) + (if file + (string-append out "/" file) + out)))) + +(define package->derivation + (store-lift package-derivation)) + +(define package->cross-derivation + (store-lift package-cross-derivation)) + +(define origin->derivation + (store-lift package-source-derivation)) diff --git a/guix/profiles.scm b/guix/profiles.scm index 44d7a314a3..921d001fa2 100644 --- a/guix/profiles.scm +++ b/guix/profiles.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> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; @@ -25,6 +25,7 @@ #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix monads) + #:use-module (guix store) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 ftw) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 781ffc5f58..e265f82b52 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.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. ;;; @@ -170,7 +170,10 @@ derivation of a package." (package-name p)))) (package-derivation store p system))) ((? procedure? proc) - (run-with-store store (proc) #:system system)))) + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) #:system system)))) (define (options->derivations+files store opts) "Given OPTS, the result of 'args-fold', return a list of derivations to diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 26e9f42774..07ced30484 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -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 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -347,12 +347,18 @@ packages." ((? package? p) `(argument . ,p)) ((? procedure? proc) - (let ((drv (run-with-store store (proc) #:system system))) + (let ((drv (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) `(argument . ,drv))) ((? gexp? gexp) (let ((drv (run-with-store store - (gexp->derivation "gexp" gexp - #:system system)))) + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system))))) `(argument . ,drv))))) (opt opt)) opts)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c388b0c52c..af196036d5 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -232,7 +232,10 @@ packages." (command (assoc-ref opts 'exec)) (inputs (packages->transitive-inputs (pick-all (options/resolve-packages opts) 'package))) - (drvs (run-with-store store (build-inputs inputs opts)))) + (drvs (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (build-inputs inputs opts))))) (cond ((assoc-ref opts 'dry-run?) #t) ((assoc-ref opts 'search-paths) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 27404772b7..b0974dcfcd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.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. ;;; @@ -553,18 +553,20 @@ Build the operating system declared in FILE according to ACTION.\n")) (set-build-options-from-command-line store opts) (run-with-store store - (perform-action action os - #:dry-run? dry? - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:image-size (assoc-ref opts 'image-size) - #:full-boot? (assoc-ref opts 'full-boot?) - #:mappings (filter-map (match-lambda - (('file-system-mapping . m) - m) - (_ #f)) - opts) - #:grub? grub? - #:target target #:device device) + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (perform-action action os + #:dry-run? dry? + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:image-size (assoc-ref opts 'image-size) + #:full-boot? (assoc-ref opts 'full-boot?) + #:mappings (filter-map (match-lambda + (('file-system-mapping . m) + m) + (_ #f)) + opts) + #:grub? grub? + #:target target #:device device)) #:system system)))) ;;; system.scm ends here diff --git a/guix/store.scm b/guix/store.scm index 571cc060d3..d3e94625a7 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix utils) #:use-module (guix config) #:use-module (guix serialization) + #:use-module (guix monads) #:autoload (guix base32) (bytevector->base32-string) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) @@ -94,6 +95,15 @@ register-path + %store-monad + store-bind + store-return + store-lift + run-with-store + %guile-for-build + text-file + interned-file + %store-prefix store-path? direct-store-path? @@ -836,6 +846,80 @@ be used internally by the daemon's build hook." ;;; +;;; Store monad. +;;; + +;; return:: a -> StoreM a +(define-inlinable (store-return value) + "Return VALUE from a monadic function." + ;; The monadic value is just this. + (lambda (store) + value)) + +;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b +(define-inlinable (store-bind mvalue mproc) + "Bind MVALUE in MPROC." + (lambda (store) + (let* ((value (mvalue store)) + (mresult (mproc value))) + (mresult store)))) + +;; This is essentially a state monad +(define-monad %store-monad + (bind store-bind) + (return store-return)) + +(define (store-lift proc) + "Lift PROC, a procedure whose first argument is a connection to the store, +in the store monad." + (define result + (lambda args + (lambda (store) + (apply proc store args)))) + + (set-object-property! result 'documentation + (procedure-property proc 'documentation)) + result) + +;; +;; Store monad operators. +;; + +(define* (text-file name text) + "Return as a monadic value the absolute file name in the store of the file +containing TEXT, a string." + (lambda (store) + (add-text-to-store store name text '()))) + +(define* (interned-file file #:optional name + #:key (recursive? #t)) + "Return the name of FILE once interned in the store. Use NAME as its store +name, or the basename of FILE if NAME is omitted. + +When RECURSIVE? is true, the contents of FILE are added recursively; if FILE +designates a flat file and RECURSIVE? is true, its contents are added, and its +permission bits are kept." + (lambda (store) + (add-to-store store (or name (basename file)) + recursive? "sha256" file))) + +(define %guile-for-build + ;; The derivation of the Guile to be used within the build environment, + ;; when using 'gexp->derivation' and co. + (make-parameter #f)) + +(define* (run-with-store store mval + #:key + (guile-for-build (%guile-for-build)) + (system (%current-system))) + "Run MVAL, a monadic value in the store monad, in STORE, an open store +connection." + (parameterize ((%guile-for-build guile-for-build) + (%current-system system)) + (mval store))) + + +;;; ;;; Store paths. ;;; diff --git a/guix/svn-download.scm b/guix/svn-download.scm index f06e449777..1c03bb9e76 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.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> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; ;;; This file is part of GNU Guix. @@ -20,6 +20,7 @@ (define-module (guix svn-download) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix monads) #:use-module (guix packages) #:use-module (ice-9 match) diff --git a/tests/monads.scm b/tests/monads.scm index 9c3cdd20a7..347a255072 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -21,8 +21,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) - #:use-module ((guix packages) - #:select (package-derivation %current-system)) + #:use-module (guix packages) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages base) #:select (coreutils)) |