nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

monads: Move '%store-monad' and related procedures where they belong. 

This turns (guix monads) into a generic module for monads, and moves the
store monad and related monadic procedures in their corresponding
module.

* guix/monads.scm (store-return, store-bind, %store-monad, store-lift,
  text-file, interned-file, package-file, package->derivation,
  package->cross-derivation, origin->derivation, imported-modules,
  compiled, modules, built-derivations, run-with-store): Move to...
* guix/store.scm (store-return, store-bind, %store-monad, store-lift,
  text-file, interned-file): ... here.
  (%guile-for-build): New variable.
  (run-with-store): Moved from monads.scm.  Remove default value for
  #:guile-for-build.
* guix/packages.scm (default-guile): Export.
  (set-guile-for-build): New procedure.
  (package-file, package->derivation, package->cross-derivation,
  origin->derivation): Moved from monads.scm.
* guix/derivations.scm (%guile-for-build): Remove.
  (imported-modules): Rename to...
  (%imported-modules): ... this.
  (compiled-modules): Rename to...
  (%compiled-modules): ... this.
  (built-derivations, imported-modules, compiled-modules): New
  procedures.
* gnu/services/avahi.scm, gnu/services/base.scm, gnu/services/dbus.scm,
  gnu/services/dmd.scm, gnu/services/networking.scm,
  gnu/services/ssh.scm, gnu/services/xorg.scm, gnu/system/install.scm,
  gnu/system/linux-initrd.scm, gnu/system/shadow.scm, guix/download.scm,
  guix/gexp.scm, guix/git-download.scm, guix/profiles.scm,
  guix/svn-download.scm, tests/monads.scm: Adjust imports accordingly.
* guix/monad-repl.scm (default-guile-derivation): New procedure.
  (store-monad-language, run-in-store): Use it.
* build-aux/hydra/gnu-system.scm (qemu-jobs): Add explicit
  'set-guile-for-build' call.
* guix/scripts/archive.scm (derivation-from-expression): Likewise.
* guix/scripts/build.scm (options/resolve-packages): Likewise.
* guix/scripts/environment.scm (guix-environment): Likewise.
* guix/scripts/system.scm (guix-system): Likewise.
* doc/guix.texi (The Store Monad): Adjust module names accordingly.
This commit is contained in:
Ludovic Courtès 2015-01-14 13:34:52 +01:00
parent 1ed194646b
commit e87f0591f3
27 changed files with 285 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
build-aux/hydra/gnu-system.scm
View File

@ -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

11
doc/guix.texi
View File

@ -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

3
gnu/services/avahi.scm
View File

@ -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))

3
gnu/services/base.scm
View File

@ -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.

3
gnu/services/dbus.scm
View File

@ -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))

4
gnu/services/dmd.scm
View File

@ -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)

3
gnu/services/networking.scm
View File

@ -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

5
gnu/services/ssh.scm
View File

@ -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:

3
gnu/services/xorg.scm
View File

@ -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)

3
gnu/system/install.scm
View File

@ -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)

3
gnu/system/linux-initrd.scm
View File

@ -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)

3
gnu/system/shadow.scm
View File

@ -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))

67
guix/derivations.scm
View File

@ -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))

4
guix/download.scm
View File

@ -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)

7
guix/gexp.scm
View File

@ -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)

3
guix/git-download.scm
View File

@ -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)

26
guix/monad-repl.scm
View File

@ -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

137
guix/monads.scm
View File

@ -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

58
guix/packages.scm
View File

@ -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))

3
guix/profiles.scm
View File

@ -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)

7
guix/scripts/archive.scm
View File

@ -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

14
guix/scripts/build.scm
View File

@ -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))

5
guix/scripts/environment.scm
View File

@ -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)

28
guix/scripts/system.scm
View File

@ -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

86
guix/store.scm
View File

@ -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?
@ -834,6 +844,80 @@ be used internally by the daemon's build hook."
;; Failed to run %GUIX-REGISTER-PROGRAM.
#f)))
;;;
;;; 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.

3
guix/svn-download.scm
View File

@ -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)

3
tests/monads.scm
View File

@ -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))