diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/derivations.scm | 67 | ||||
| -rw-r--r-- | guix/download.scm | 41 | ||||
| -rw-r--r-- | guix/gexp.scm | 7 | ||||
| -rw-r--r-- | guix/git-download.scm | 31 | ||||
| -rw-r--r-- | guix/monad-repl.scm | 26 | ||||
| -rw-r--r-- | guix/monads.scm | 137 | ||||
| -rw-r--r-- | guix/packages.scm | 127 | ||||
| -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 | 93 | ||||
| -rw-r--r-- | guix/svn-download.scm | 31 |
14 files changed, 321 insertions, 296 deletions
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..9a1897525b 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) @@ -197,27 +197,22 @@ (let ((module (resolve-interface '(gnu packages gnutls)))) (module-ref module 'gnutls))) -(define* (url-fetch store url hash-algo hash +(define* (url-fetch url hash-algo hash #:optional name - #:key (system (%current-system)) guile + #:key (system (%current-system)) + (guile (default-guile)) (mirrors %mirrors)) - "Return the path of a fixed-output derivation in STORE that fetches -URL (a string, or a list of strings denoting alternate URLs), which is -expected to have hash HASH of type HASH-ALGO (a symbol). By default, -the file name is the base name of URL; optionally, NAME can specify a -different file name. + "Return a fixed-output derivation that fetches URL (a string, or a list of +strings denoting alternate URLs), which is expected to have hash HASH of type +HASH-ALGO (a symbol). By default, the file name is the base name of URL; +optionally, NAME can specify a different file name. When one of the URL starts with mirror://, then its host part is interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS -must be a list of symbol/URL-list pairs." - (define guile-for-build - (package-derivation store - (or guile - (let ((distro (resolve-interface - '(gnu packages commencement)))) - (module-ref distro 'guile-final))) - system)) +must be a list of symbol/URL-list pairs. +Alternately, when URL starts with file://, return the corresponding file name +in the store." (define file-name (match url ((head _ ...) @@ -254,26 +249,24 @@ must be a list of symbol/URL-list pairs." (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) (and uri (memq (uri-scheme uri) '(#f file)))) - (add-to-store store (or name file-name) - #f "sha256" (if uri (uri-path uri) url)) - (run-with-store store + (interned-file (if uri (uri-path uri) url) + (or name file-name)) + (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name file-name) builder + #:guile-for-build guile #:system system #:hash-algo hash-algo #:hash hash #:modules '((guix build download) (guix build utils) (guix ftp-client)) - #:guile-for-build guile-for-build ;; In general, offloading downloads is not a good idea. ;;#:local-build? #t ;; FIXME: The above would also disable use of ;; substitutes, so comment it out; see ;; <https://bugs.gnu.org/18747>. - ) - #:guile-for-build guile-for-build - #:system system)))) + ))))) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port))) 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..94a1245480 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) @@ -52,23 +53,13 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'git))) -(define* (git-fetch store ref hash-algo hash +(define* (git-fetch ref hash-algo hash #:optional name - #:key (system (%current-system)) guile + #:key (system (%current-system)) (guile (default-guile)) (git (git-package))) - "Return a fixed-output derivation in STORE that fetches REF, a -<git-reference> object. The output is expected to have recursive hash HASH of -type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if -#f." - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system))))) - + "Return a fixed-output derivation that fetches REF, a <git-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define inputs ;; When doing 'git clone --recursive', we need sed, grep, etc. to be ;; available so that 'git submodule' works. @@ -95,7 +86,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #:recursive? '#$(git-reference-recursive? ref) #:git-command (string-append #$git "/bin/git")))) - (run-with-store store + (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build #:system system ;; FIXME: See <https://bugs.gnu.org/18747>. @@ -105,9 +96,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #:recursive? #t #:modules '((guix build git) (guix build utils)) - #:guile-for-build guile-for-build - #:local-build? #t) - #:guile-for-build guile-for-build - #:system system)) + #:guile-for-build guile + #:local-build? #t))) ;;; git-download.scm ends here 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 68fd531c6b..db14f9e0b8 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: ;;; @@ -322,10 +331,12 @@ 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))) +;; TODO: Rewrite using %STORE-MONAD and gexps. (define* (patch-and-repack store source patches #:key (inputs '()) @@ -474,37 +485,6 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." #:modules modules #:guile-for-build guile-for-build))) -(define* (package-source-derivation store source - #:optional (system (%current-system))) - "Return the derivation path for SOURCE, a package source, for SYSTEM." - (match source - (($ <origin> uri method sha256 name () #f) - ;; No patches, no snippet: this is a fixed-output derivation. - (method store uri 'sha256 sha256 name - #:system system)) - (($ <origin> uri method sha256 name (patches ...) snippet - (flags ...) inputs (modules ...) (imported-modules ...) - guile-for-build) - ;; Patches and/or a snippet. - (let ((source (method store uri 'sha256 sha256 name - #:system system)) - (guile (match (or guile-for-build (default-guile)) - ((? package? p) - (package-derivation store p system - #:graft? #f))))) - (patch-and-repack store source patches - #:inputs inputs - #:snippet snippet - #:flags flags - #:system system - #:modules modules - #:imported-modules modules - #:guile-for-build guile))) - ((and (? string?) (? direct-store-path?) file) - file) - ((? string? file) - (add-to-store store (basename file) #t "sha256" file)))) - (define (transitive-inputs inputs) (let loop ((inputs inputs) (result '())) @@ -907,3 +887,82 @@ 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 patch-and-repack* + (store-lift patch-and-repack)) + +(define* (origin->derivation source + #:optional (system (%current-system))) + "When SOURCE is an <origin> object, return its derivation for SYSTEM. When +SOURCE is a file name, return either the interned file name (if SOURCE is +outside of the store) or SOURCE itself (if SOURCE is already a store item.)" + (match source + (($ <origin> uri method sha256 name () #f) + ;; No patches, no snippet: this is a fixed-output derivation. + (method uri 'sha256 sha256 name #:system system)) + (($ <origin> uri method sha256 name (patches ...) snippet + (flags ...) inputs (modules ...) (imported-modules ...) + guile-for-build) + ;; Patches and/or a snippet. + (mlet %store-monad ((source (method uri 'sha256 sha256 name + #:system system)) + (guile (package->derivation (or guile-for-build + (default-guile)) + system + #:graft? #f))) + (patch-and-repack* source patches + #:inputs inputs + #:snippet snippet + #:flags flags + #:system system + #:modules modules + #:imported-modules modules + #:guile-for-build guile))) + ((and (? string?) (? direct-store-path?) file) + (with-monad %store-monad + (return file))) + ((? string? file) + (interned-file file (basename file) + #:recursive? #t)))) + +(define package-source-derivation + (store-lower origin->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 b3a79d9251..ffa3a09799 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -230,7 +230,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..82ed94bbc1 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,16 @@ register-path + %store-monad + store-bind + store-return + store-lift + store-lower + run-with-store + %guile-for-build + text-file + interned-file + %store-prefix store-path? direct-store-path? @@ -836,6 +847,86 @@ 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) + +(define (store-lower proc) + "Lower PROC, a monadic procedure in %STORE-MONAD, to a \"normal\" procedure +taking the store as its first argument." + (lambda (store . args) + (run-with-store store (apply proc args)))) + +;; +;; 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..ee67513e16 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) @@ -48,23 +49,13 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'subversion))) -(define* (svn-fetch store ref hash-algo hash +(define* (svn-fetch ref hash-algo hash #:optional name - #:key (system (%current-system)) guile + #:key (system (%current-system)) (guile (default-guile)) (svn (subversion-package))) - "Return a fixed-output derivation in STORE that fetches REF, a -<svn-reference> object. The output is expected to have recursive hash HASH of -type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if -#f." - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system))))) - + "Return a fixed-output derivation that fetches REF, a <svn-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build #~(begin (use-modules (guix build svn)) @@ -73,7 +64,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #$output #:svn-command (string-append #$svn "/bin/svn")))) - (run-with-store store + (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build #:system system ;; FIXME: See <https://bugs.gnu.org/18747>. @@ -83,9 +74,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #:recursive? #t #:modules '((guix build svn) (guix build utils)) - #:guile-for-build guile-for-build - #:local-build? #t) - #:guile-for-build guile-for-build - #:system system)) + #:guile-for-build guile + #:local-build? #t))) ;;; svn-download.scm ends here |