From e87f0591f3117ed61285f33c7cc3548f72e551ad Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 14 Jan 2015 13:34:52 +0100
Subject: 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.
---
 guix/store.scm | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 85 insertions(+), 1 deletion(-)

(limited to 'guix/store.scm')

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?
@@ -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.
-- 
cgit v1.2.3