unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps
@ 2018-05-28 21:56 Ludovic Courtès
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
  2018-06-01  7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic
  0 siblings, 2 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:56 UTC (permalink / raw)
  To: 31633

Hello Guix!

These patches add a ‘with-extensions’ form for gexps and then use it.
‘with-extensions’ is akin to ‘with-imported-modules’, except that it
lists “full-blown” Guile packages where modules are available under
/share/guile/site/2.2 etc.

This fixes a longstanding issue where using extensions in gexps would be
inconvenient to say the least.

Extensions can be thought of as a generalization of “imported modules”
in that the latter could be implemented in terms of the former.  Perhaps
we should do that eventually, though that means that ‘compiled-modules’
and ‘imported-modules’ will have to put files in /share/guile and
/lib/guile like “real” packages do.

Feedback welcome!

Ludo’.

Ludovic Courtès (7):
  gexp: Add 'with-extensions'.
  pack: Use 'with-extensions' when referring to (guix docker).
  tests: ssh: Use 'with-extensions'.
  bootloader: grub: Simplify 'svg->png'.
  bootloader: grub: Use 'with-extensions'.
  profiles: Use 'with-extensions'.
  vm: Use 'with-extensions'.

 .dir-locals.el          |   1 +
 doc/guix.texi           |  33 +++++
 gnu/bootloader/grub.scm |  19 +--
 gnu/build/svg.scm       |  11 +-
 gnu/system/vm.scm       |  93 +++++++-------
 gnu/tests/ssh.scm       | 262 ++++++++++++++++++++--------------------
 guix/docker.scm         |   6 +-
 guix/gexp.scm           | 168 +++++++++++++++++++-------
 guix/man-db.scm         |   6 +-
 guix/profiles.scm       |  60 +++++----
 guix/scripts/pack.scm   |  37 +++---
 tests/gexp.scm          |  86 +++++++++++++
 12 files changed, 477 insertions(+), 305 deletions(-)

-- 
2.17.0

^ permalink raw reply	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions'.
  2018-05-28 21:56 [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Ludovic Courtès
@ 2018-05-28 21:59 ` Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès
                     ` (5 more replies)
  2018-06-01  7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic
  1 sibling, 6 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* guix/gexp.scm (<gexp>)[extensions]: New field.
(gexp-attribute): New procedure.
(gexp-modules): Write in terms of 'gexp-attribute'.
(gexp-extensions): New procedure.
(gexp->derivation): Add #:effective-version.
[extension-flags]: New procedure.
Honor extensions of EXP.
(current-imported-extensions): New syntax parameter.
(with-extensions): New macro.
(gexp): Honor CURRENT-IMPORTED-EXTENSIONS.
(compiled-modules): Add #:extensions and honor it.
(load-path-expression): Likewise.
(gexp->script, gexp->file): Honor extensions.
* tests/gexp.scm (%extension-package): New variable.
("gexp-extensions & ungexp")
("gexp-extensions & ungexp-splicing")
("gexp-extensions and literal Scheme object")
("gexp->derivation & with-extensions")
("program-file & with-extensions"): New tests.
* doc/guix.texi (G-Expressions): Document 'with-extensions'.
---
 .dir-locals.el |   1 +
 doc/guix.texi  |  33 ++++++++++
 guix/gexp.scm  | 168 ++++++++++++++++++++++++++++++++++++-------------
 tests/gexp.scm |  86 +++++++++++++++++++++++++
 4 files changed, 246 insertions(+), 42 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index dac6cb145..2db751ca2 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -73,6 +73,7 @@
    (eval . (put 'run-with-state 'scheme-indent-function 1))
    (eval . (put 'wrap-program 'scheme-indent-function 1))
    (eval . (put 'with-imported-modules 'scheme-indent-function 1))
+   (eval . (put 'with-extensions 'scheme-indent-function 1))
 
    (eval . (put 'call-with-container 'scheme-indent-function 1))
    (eval . (put 'container-excursion 'scheme-indent-function 1))
diff --git a/doc/guix.texi b/doc/guix.texi
index 5eee40fc3..e55fecc31 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5041,6 +5041,23 @@ headers, which comes in handy in this case:
                         @dots{})))
 @end example
 
+@cindex extensions, for gexps
+@findex with-extensions
+In the same vein, sometimes you want to import not just pure-Scheme
+modules, but also ``extensions'' such as Guile bindings to C libraries
+or other ``full-blown'' packages.  Say you need the @code{guile-json}
+package available on the build side, here's how you would do it:
+
+@example
+(use-modules (gnu packages guile))  ;for 'guile-json'
+
+(with-extensions (list guile-json)
+  (gexp->derivation "something-with-json"
+                    #~(begin
+                        (use-modules (json))
+                        @dots{})))
+@end example
+
 The syntactic form to construct gexps is summarized below.
 
 @deffn {Scheme Syntax} #~@var{exp}
@@ -5124,6 +5141,18 @@ directly defined in @var{body}@dots{}, but not on those defined, say, in
 procedures called from @var{body}@dots{}.
 @end deffn
 
+@deffn {Scheme Syntax} with-extensions @var{extensions} @var{body}@dots{}
+Mark the gexps defined in @var{body}@dots{} as requiring
+@var{extensions} in their build and execution environment.
+@var{extensions} is typically a list of package objects such as those
+defined in the @code{(gnu packages guile)} module.
+
+Concretely, the packages listed in @var{extensions} are added to the
+load path while compiling imported modules in @var{body}@dots{}; they
+are also added to the load path of the gexp returned by
+@var{body}@dots{}.
+@end deffn
+
 @deffn {Scheme Procedure} gexp? @var{obj}
 Return @code{#t} if @var{obj} is a G-expression.
 @end deffn
@@ -5138,6 +5167,7 @@ information about monads.)
        [#:hash #f] [#:hash-algo #f] @
        [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
        [#:module-path @var{%load-path}] @
+       [#:effective-version "2.2"] @
        [#:references-graphs #f] [#:allowed-references #f] @
        [#:disallowed-references #f] @
        [#:leaked-env-vars #f] @
@@ -5158,6 +5188,9 @@ make @var{modules} available in the evaluation context of @var{exp};
 the load path during the execution of @var{exp}---e.g., @code{((guix
 build utils) (guix build gnu-build-system))}.
 
+@var{effective-version} determines the string to use when adding extensions of
+@var{exp} (see @code{with-extensions}) to the search path---e.g., @code{"2.2"}.
+
 @var{graft?} determines whether packages referred to by @var{exp} should be grafted when
 applicable.
 
diff --git a/guix/gexp.scm b/guix/gexp.scm
index dd5eb81bd..eda962d0a 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -33,6 +33,7 @@
   #:export (gexp
             gexp?
             with-imported-modules
+            with-extensions
 
             gexp-input
             gexp-input?
@@ -118,10 +119,11 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references modules proc)
+  (make-gexp references modules extensions proc)
   gexp?
   (references gexp-references)                    ;list of <gexp-input>
   (modules    gexp-self-modules)                  ;list of module names
+  (extensions gexp-self-extensions)               ;list of lowerable things
   (proc       gexp-proc))                         ;procedure
 
 (define (write-gexp gexp port)
@@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not."
 
 (set-record-type-printer! <gexp-output> write-gexp-output)
 
-(define (gexp-modules gexp)
-  "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
-false, meaning that GEXP is a plain Scheme object, return the empty list."
+(define (gexp-attribute gexp self-attribute)
+  "Recurse on GEXP and the expressions it refers to, summing the items
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
   (if (gexp? gexp)
       (delete-duplicates
-       (append (gexp-self-modules gexp)
+       (append (self-attribute gexp)
                (append-map (match-lambda
                              (($ <gexp-input> (? gexp? exp))
-                              (gexp-modules exp))
+                              (gexp-attribute exp self-attribute))
                              (($ <gexp-input> (lst ...))
                               (append-map (lambda (item)
                                             (if (gexp? item)
-                                                (gexp-modules item)
+                                                (gexp-attribute item
+                                                                self-attribute)
                                                 '()))
                                           lst))
                              (_
@@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
                            (gexp-references gexp))))
       '()))                                       ;plain Scheme data type
 
+(define (gexp-modules gexp)
+  "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
+false, meaning that GEXP is a plain Scheme object, return the empty list."
+  (gexp-attribute gexp gexp-self-modules))
+
+(define (gexp-extensions gexp)
+  "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
+GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
+list."
+  (gexp-attribute gexp gexp-self-extensions))
+
 (define* (lower-inputs inputs
                        #:key system target)
   "Turn any package from INPUTS into a derivation for SYSTEM; return the
@@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
                            (modules '())
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
+                           (effective-version "2.2")
                            (graft? (%graft?))
                            references-graphs
                            allowed-references disallowed-references
@@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
 compiled, and made available in the load path during the execution of
 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 
+EFFECTIVE-VERSION determines the string to use when adding extensions of
+EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
+
 GRAFT? determines whether packages referred to by EXP should be grafted when
 applicable.
 
@@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
   (define (graphs-file-names graphs)
     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
     (map (match-lambda
-          ;; TODO: Remove 'derivation?' special cases.
+           ;; TODO: Remove 'derivation?' special cases.
            ((file-name (? derivation? drv))
             (cons file-name (derivation->output-path drv)))
            ((file-name (? derivation? drv) sub-drv)
@@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
             (cons file-name thing)))
          graphs))
 
-  (mlet* %store-monad (;; The following binding forces '%current-system' and
+  (define (extension-flags extension)
+    `("-L" ,(string-append (derivation->output-path extension)
+                           "/share/guile/site/" effective-version)
+      "-C" ,(string-append (derivation->output-path extension)
+                           "/lib/guile/" effective-version "/site-ccache")))
+
+  (mlet* %store-monad ( ;; The following binding forces '%current-system' and
                        ;; '%current-target-system' to be looked up at >>=
                        ;; time.
                        (graft?    (set-grafting graft?))
@@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
                                              #:target target))
                        (builder  (text-file script-name
                                             (object->string sexp)))
+                       (extensions -> (gexp-extensions exp))
+                       (exts     (mapm %store-monad
+                                       (lambda (obj)
+                                         (lower-object obj system))
+                                       extensions))
                        (modules  (if (pair? %modules)
                                      (imported-modules %modules
                                                        #:system system
@@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
                                      (compiled-modules %modules
                                                        #:system system
                                                        #:module-path module-path
+                                                       #:extensions extensions
                                                        #:guile guile-for-build
                                                        #:deprecation-warnings
                                                        deprecation-warnings)
@@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
                               `("-L" ,(derivation->output-path modules)
                                 "-C" ,(derivation->output-path compiled))
                               '())
+                        ,@(append-map extension-flags exts)
                         ,builder)
                       #:outputs outputs
                       #:env-vars env-vars
@@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
                                  ,@(if modules
                                        `((,modules) (,compiled) ,@inputs)
                                        inputs)
+                                 ,@(map list exts)
                                  ,@(match graphs
                                      (((_ . inputs) ...) inputs)
                                      (_ '())))
@@ -861,6 +893,17 @@ environment."
                          (identifier-syntax modules)))
     body ...))
 
+(define-syntax-parameter current-imported-extensions
+  ;; Current list of extensions.
+  (identifier-syntax '()))
+
+(define-syntax-rule (with-extensions extensions body ...)
+  "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
+execution environment."
+  (syntax-parameterize ((current-imported-extensions
+                         (identifier-syntax extensions)))
+    body ...))
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
@@ -957,6 +1000,7 @@ environment."
               (refs    (map escape->ref escapes)))
          #`(make-gexp (list #,@refs)
                       current-imported-modules
+                      current-imported-extensions
                       (lambda #,formals
                         #,sexp)))))))
 
@@ -1071,6 +1115,7 @@ last one is created from the given <scheme-file> object."
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
+                           (extensions '())
                            (deprecation-warnings #f))
   "Return a derivation that builds a tree containing the `.go' files
 corresponding to MODULES.  All the MODULES are built in a context where
@@ -1114,6 +1159,26 @@ they can refer to each other."
                                              %auto-compilation-options))))
                        entries)))
 
+         ;; Add EXTENSIONS to the search path.
+         ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
+         (ungexp-splicing
+          (if (null? extensions)
+              '()
+              (gexp ((set! %load-path
+                       (append (map (lambda (extension)
+                                      (string-append extension
+                                                     "/share/guile/site/"
+                                                     (effective-version)))
+                                    '((ungexp-native-splicing extensions)))
+                               %load-path))
+                     (set! %load-compiled-path
+                       (append (map (lambda (extension)
+                                      (string-append extension "/lib/guile/"
+                                                     (effective-version)
+                                                     "/site-ccache"))
+                                    '((ungexp-native-splicing extensions)))
+                               %load-compiled-path))))))
+
          (set! %load-path (cons (ungexp modules) %load-path))
          (mkdir (ungexp output))
          (chdir (ungexp modules))
@@ -1146,20 +1211,34 @@ they can refer to each other."
   (module-ref (resolve-interface '(gnu packages guile))
               'guile-2.2))
 
-(define* (load-path-expression modules #:optional (path %load-path))
+(define* (load-path-expression modules #:optional (path %load-path)
+                               #:key (extensions '()))
   "Return as a monadic value a gexp that sets '%load-path' and
 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 are searched for in PATH."
   (mlet %store-monad ((modules  (imported-modules modules
                                                   #:module-path path))
                       (compiled (compiled-modules modules
+                                                  #:extensions extensions
                                                   #:module-path path)))
     (return (gexp (eval-when (expand load eval)
                     (set! %load-path
-                      (cons (ungexp modules) %load-path))
+                      (cons (ungexp modules)
+                            (append (map (lambda (extension)
+                                           (string-append extension
+                                                          "/share/guile/site/"
+                                                          (effective-version)))
+                                         '((ungexp-native-splicing extensions)))
+                                    %load-path)))
                     (set! %load-compiled-path
                       (cons (ungexp compiled)
-                            %load-compiled-path)))))))
+                            (append (map (lambda (extension)
+                                           (string-append extension
+                                                          "/lib/guile/"
+                                                          (effective-version)
+                                                          "/site-ccache"))
+                                         '((ungexp-native-splicing extensions)))
+                                    %load-compiled-path))))))))
 
 (define* (gexp->script name exp
                        #:key (guile (default-guile))
@@ -1168,7 +1247,9 @@ are searched for in PATH."
 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
   (mlet %store-monad ((set-load-path
                        (load-path-expression (gexp-modules exp)
-                                             module-path)))
+                                             module-path
+                                             #:extensions
+                                             (gexp-extensions exp))))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
@@ -1197,35 +1278,38 @@ the resulting file.
 When SET-LOAD-PATH? is true, emit code in the resulting file to set
 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
 Lookup EXP's modules in MODULE-PATH."
-  (match (if set-load-path? (gexp-modules exp) '())
-    (()                                           ;zero modules
-     (gexp->derivation name
-                       (gexp
-                        (call-with-output-file (ungexp output)
-                          (lambda (port)
-                            (for-each (lambda (exp)
-                                        (write exp port))
-                                      '(ungexp (if splice?
-                                                   exp
-                                                   (gexp ((ungexp exp)))))))))
-                       #:local-build? #t
-                       #:substitutable? #f))
-    ((modules ...)
-     (mlet %store-monad ((set-load-path (load-path-expression modules
-                                                              module-path)))
-       (gexp->derivation name
-                         (gexp
-                          (call-with-output-file (ungexp output)
-                            (lambda (port)
-                              (write '(ungexp set-load-path) port)
-                              (for-each (lambda (exp)
-                                          (write exp port))
-                                        '(ungexp (if splice?
-                                                     exp
-                                                     (gexp ((ungexp exp)))))))))
-                         #:module-path module-path
-                         #:local-build? #t
-                         #:substitutable? #f)))))
+  (define modules (gexp-modules exp))
+  (define extensions (gexp-extensions exp))
+
+  (if (or (not set-load-path?)
+          (and (null? modules) (null? extensions)))
+      (gexp->derivation name
+                        (gexp
+                         (call-with-output-file (ungexp output)
+                           (lambda (port)
+                             (for-each (lambda (exp)
+                                         (write exp port))
+                                       '(ungexp (if splice?
+                                                    exp
+                                                    (gexp ((ungexp exp)))))))))
+                        #:local-build? #t
+                        #:substitutable? #f)
+      (mlet %store-monad ((set-load-path
+                           (load-path-expression modules module-path
+                                                 #:extensions extensions)))
+        (gexp->derivation name
+                          (gexp
+                           (call-with-output-file (ungexp output)
+                             (lambda (port)
+                               (write '(ungexp set-load-path) port)
+                               (for-each (lambda (exp)
+                                           (write exp port))
+                                         '(ungexp (if splice?
+                                                      exp
+                                                      (gexp ((ungexp exp)))))))))
+                          #:module-path module-path
+                          #:local-build? #t
+                          #:substitutable? #f))))
 
 (define* (text-file* name #:rest text)
   "Return as a monadic value a derivation that builds a text file containing
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 3c8b4624d..a560adfc5 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -23,6 +23,7 @@
   #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix build-system trivial)
   #:use-module (guix tests)
   #:use-module ((guix build utils) #:select (with-directory-excursion))
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
@@ -66,6 +67,27 @@
     (run-with-store %store exp
                     #:guile-for-build (%guile-for-build))))
 
+(define %extension-package
+  ;; Example of a package to use when testing 'with-extensions'.
+  (dummy-package "extension"
+                 (build-system trivial-build-system)
+                 (arguments
+                  `(#:guile ,%bootstrap-guile
+                    #:modules ((guix build utils))
+                    #:builder
+                    (begin
+                      (use-modules (guix build utils))
+                      (let* ((out (string-append (assoc-ref %outputs "out")
+                                                 "/share/guile/site/"
+                                                 (effective-version))))
+                        (mkdir-p out)
+                        (call-with-output-file (string-append out "/hg2g.scm")
+                          (lambda (port)
+                            (write '(define-module (hg2g)
+                                      #:export (the-answer))
+                                   port)
+                            (write '(define the-answer 42) port)))))))))
+
 \f
 (test-begin "gexp")
 
@@ -739,6 +761,54 @@
       (built-derivations (list drv))
       (return (= 42 (call-with-input-file out read))))))
 
+(test-equal "gexp-extensions & ungexp"
+  (list sed grep)
+  ((@@ (guix gexp) gexp-extensions)
+   #~(foo #$(with-extensions (list grep) #~+)
+          #+(with-extensions (list sed)  #~-))))
+
+(test-equal "gexp-extensions & ungexp-splicing"
+  (list grep sed)
+  ((@@ (guix gexp) gexp-extensions)
+   #~(foo #$@(list (with-extensions (list grep) #~+)
+                   (with-imported-modules '((foo))
+                     (with-extensions (list sed) #~-))))))
+
+(test-equal "gexp-extensions and literal Scheme object"
+  '()
+  ((@@ (guix gexp) gexp-extensions) #t))
+
+(test-assertm "gexp->derivation & with-extensions"
+  ;; Create a fake Guile extension and make sure it is accessible both to the
+  ;; imported modules and to the derivation build script.
+  (mlet* %store-monad
+      ((extension -> %extension-package)
+       (module -> (scheme-file "x" #~( ;; splice!
+                                      (define-module (foo)
+                                        #:use-module (hg2g)
+                                        #:export (multiply))
+
+                                      (define (multiply x)
+                                        (* the-answer x)))
+                               #:splice? #t))
+       (build -> (with-extensions (list extension)
+                   (with-imported-modules `((guix build utils)
+                                            ((foo) => ,module))
+                     #~(begin
+                         (use-modules (guix build utils)
+                                      (hg2g) (foo))
+                         (call-with-output-file #$output
+                           (lambda (port)
+                             (write (list the-answer (multiply 2))
+                                    port)))))))
+       (drv      (gexp->derivation "thingie" build
+                                   ;; %BOOTSTRAP-GUILE is 2.0.
+                                   #:effective-version "2.0"))
+       (out ->   (derivation->output-path drv)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (return (equal? '(42 84) (call-with-input-file out read))))))
+
 (test-assertm "gexp->derivation #:references-graphs"
   (mlet* %store-monad
       ((one (text-file "one" (random-text)))
@@ -948,6 +1018,22 @@
              (return (and (zero? (close-pipe pipe))
                           (string=? text str))))))))))
 
+(test-assertm "program-file & with-extensions"
+  (let* ((exp    (with-extensions (list %extension-package)
+                   (gexp (begin
+                           (use-modules (hg2g))
+                           (display the-answer)))))
+         (file   (program-file "program" exp
+                               #:guile %bootstrap-guile)))
+    (mlet* %store-monad ((drv (lower-object file))
+                         (out -> (derivation->output-path drv)))
+      (mbegin %store-monad
+        (built-derivations (list drv))
+        (let* ((pipe  (open-input-pipe out))
+               (str   (get-string-all pipe)))
+          (return (and (zero? (close-pipe pipe))
+                       (= 42 (string->number str)))))))))
+
 (test-assertm "scheme-file"
   (let* ((text   (plain-file "foo" "Hello, world!"))
          (scheme (scheme-file "bar" #~(list "foo" #$text))))
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker).
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
@ 2018-05-28 21:59   ` Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions' Ludovic Courtès
                     ` (4 subsequent siblings)
  5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* guix/docker.scm: Use module (json) the normal way.
* guix/scripts/pack.scm (docker-image)[build]: Wrap in
'with-extensions'.
---
 guix/docker.scm       |  6 ++----
 guix/scripts/pack.scm | 37 +++++++++++++++++--------------------
 2 files changed, 19 insertions(+), 24 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index a75534c33..b86990159 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module ((texinfo string-utils)
@@ -34,9 +35,6 @@
   #:use-module (ice-9 match)
   #:export (build-docker-image))
 
-;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
-(module-use! (current-module) (resolve-interface '(json)))
-
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
   (compose bytevector->base16-string sha256 string->utf8))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1e84459e7..f5e247ed7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -256,28 +256,25 @@ the image."
         guile-json))
 
   (define build
-    (with-imported-modules `(,@(source-module-closure '((guix docker))
-                                                      #:select? not-config?)
-                             (guix build store-copy)
-                             ((guix config) => ,config))
-      #~(begin
-          ;; Guile-JSON is required by (guix docker).
-          (add-to-load-path
-           (string-append #+json "/share/guile/site/"
-                          (effective-version)))
+    ;; Guile-JSON is required by (guix docker).
+    (with-extensions (list json)
+      (with-imported-modules `(,@(source-module-closure '((guix docker))
+                                                        #:select? not-config?)
+                               (guix build store-copy)
+                               ((guix config) => ,config))
+        #~(begin
+            (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 
-          (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+            (setenv "PATH" (string-append #$tar "/bin"))
 
-          (setenv "PATH" (string-append #$tar "/bin"))
-
-          (build-docker-image #$output
-                              (call-with-input-file "profile"
-                                read-reference-graph)
-                              #$profile
-                              #:system (or #$target (utsname:machine (uname)))
-                              #:symlinks '#$symlinks
-                              #:compressor '#$(compressor-command compressor)
-                              #:creation-time (make-time time-utc 0 1)))))
+            (build-docker-image #$output
+                                (call-with-input-file "profile"
+                                  read-reference-graph)
+                                #$profile
+                                #:system (or #$target (utsname:machine (uname)))
+                                #:symlinks '#$symlinks
+                                #:compressor '#$(compressor-command compressor)
+                                #:creation-time (make-time time-utc 0 1))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions'.
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès
@ 2018-05-28 21:59   ` Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png' Ludovic Courtès
                     ` (3 subsequent siblings)
  5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* gnu/tests/ssh.scm (run-ssh-test)[test]: Wrap body in
'with-extensions'.  Remove %load-path manipulation code.
---
 gnu/tests/ssh.scm | 262 ++++++++++++++++++++++------------------------
 1 file changed, 128 insertions(+), 134 deletions(-)

diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 6abc6c250..9247a43e6 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;;
@@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test."
 
   (define test
     (with-imported-modules '((gnu build marionette))
-      #~(begin
-          (eval-when (expand load eval)
-            ;; Prepare to use Guile-SSH.
-            (set! %load-path
-              (cons (string-append #+guile-ssh "/share/guile/site/"
-                                   (effective-version))
-                    %load-path)))
+      (with-extensions (list guile-ssh)
+        #~(begin
+            (use-modules (gnu build marionette)
+                         (srfi srfi-26)
+                         (srfi srfi-64)
+                         (ice-9 match)
+                         (ssh session)
+                         (ssh auth)
+                         (ssh channel)
+                         (ssh sftp))
 
-          (use-modules (gnu build marionette)
-                       (srfi srfi-26)
-                       (srfi srfi-64)
-                       (ice-9 match)
-                       (ssh session)
-                       (ssh auth)
-                       (ssh channel)
-                       (ssh sftp))
+            (define marionette
+              ;; Enable TCP forwarding of the guest's port 22.
+              (make-marionette (list #$vm)))
 
-          (define marionette
-            ;; Enable TCP forwarding of the guest's port 22.
-            (make-marionette (list #$vm)))
+            (define (make-session-for-test)
+              "Make a session with predefined parameters for a test."
+              (make-session #:user "root"
+                            #:port 2222
+                            #:host "localhost"
+                            #:log-verbosity 'protocol))
 
-          (define (make-session-for-test)
-            "Make a session with predefined parameters for a test."
-            (make-session #:user "root"
-                          #:port 2222
-                          #:host "localhost"
-                          #:log-verbosity 'protocol))
-
-          (define (call-with-connected-session proc)
-            "Call the one-argument procedure PROC with a freshly created and
+            (define (call-with-connected-session proc)
+              "Call the one-argument procedure PROC with a freshly created and
 connected SSH session object, return the result of the procedure call.  The
 session is disconnected when the PROC is finished."
-            (let ((session (make-session-for-test)))
-              (dynamic-wind
-                (lambda ()
-                  (let ((result (connect! session)))
-                    (unless (equal? result 'ok)
-                      (error "Could not connect to a server"
-                             session result))))
-                (lambda () (proc session))
-                (lambda () (disconnect! session)))))
+              (let ((session (make-session-for-test)))
+                (dynamic-wind
+                  (lambda ()
+                    (let ((result (connect! session)))
+                      (unless (equal? result 'ok)
+                        (error "Could not connect to a server"
+                               session result))))
+                  (lambda () (proc session))
+                  (lambda () (disconnect! session)))))
 
-          (define (call-with-connected-session/auth proc)
-            "Make an authenticated session.  We should be able to connect as
+            (define (call-with-connected-session/auth proc)
+              "Make an authenticated session.  We should be able to connect as
 root with an empty password."
-            (call-with-connected-session
-             (lambda (session)
-               ;; Try the simple authentication methods.  Dropbear requires
-               ;; 'none' when there are no passwords, whereas OpenSSH accepts
-               ;; 'password' with an empty password.
-               (let loop ((methods (list (cut userauth-password! <> "")
-                                         (cut userauth-none! <>))))
-                 (match methods
-                   (()
-                    (error "all the authentication methods failed"))
-                   ((auth rest ...)
-                    (match (pk 'auth (auth session))
-                      ('success
-                       (proc session))
-                      ('denied
-                       (loop rest)))))))))
+              (call-with-connected-session
+               (lambda (session)
+                 ;; Try the simple authentication methods.  Dropbear requires
+                 ;; 'none' when there are no passwords, whereas OpenSSH accepts
+                 ;; 'password' with an empty password.
+                 (let loop ((methods (list (cut userauth-password! <> "")
+                                           (cut userauth-none! <>))))
+                   (match methods
+                     (()
+                      (error "all the authentication methods failed"))
+                     ((auth rest ...)
+                      (match (pk 'auth (auth session))
+                        ('success
+                         (proc session))
+                        ('denied
+                         (loop rest)))))))))
 
-          (mkdir #$output)
-          (chdir #$output)
+            (mkdir #$output)
+            (chdir #$output)
 
-          (test-begin "ssh-daemon")
+            (test-begin "ssh-daemon")
 
-          ;; Wait for sshd to be up and running.
-          (test-eq "service running"
-            'running!
-            (marionette-eval
-             '(begin
-                (use-modules (gnu services herd))
-                (start-service 'ssh-daemon)
-                'running!)
-             marionette))
+            ;; Wait for sshd to be up and running.
+            (test-eq "service running"
+              'running!
+              (marionette-eval
+               '(begin
+                  (use-modules (gnu services herd))
+                  (start-service 'ssh-daemon)
+                  'running!)
+               marionette))
 
-          ;; Check sshd's PID file.
-          (test-equal "sshd PID"
-            (wait-for-file #$pid-file marionette)
-            (marionette-eval
-             '(begin
-                (use-modules (gnu services herd)
-                             (srfi srfi-1))
+            ;; Check sshd's PID file.
+            (test-equal "sshd PID"
+              (wait-for-file #$pid-file marionette)
+              (marionette-eval
+               '(begin
+                  (use-modules (gnu services herd)
+                               (srfi srfi-1))
 
-                (live-service-running
-                 (find (lambda (live)
-                         (memq 'ssh-daemon
-                               (live-service-provision live)))
-                       (current-services))))
-             marionette))
+                  (live-service-running
+                   (find (lambda (live)
+                           (memq 'ssh-daemon
+                                 (live-service-provision live)))
+                         (current-services))))
+               marionette))
 
-          ;; Connect to the guest over SSH.  Make sure we can run a shell
-          ;; command there.
-          (test-equal "shell command"
-            'hello
-            (call-with-connected-session/auth
-             (lambda (session)
-               ;; FIXME: 'get-server-public-key' segfaults.
-               ;; (get-server-public-key session)
-               (let ((channel (make-channel session)))
-                 (channel-open-session channel)
-                 (channel-request-exec channel "echo hello > /root/witness")
-                 (and (zero? (channel-get-exit-status channel))
-                      (wait-for-file "/root/witness" marionette))))))
+            ;; Connect to the guest over SSH.  Make sure we can run a shell
+            ;; command there.
+            (test-equal "shell command"
+              'hello
+              (call-with-connected-session/auth
+               (lambda (session)
+                 ;; FIXME: 'get-server-public-key' segfaults.
+                 ;; (get-server-public-key session)
+                 (let ((channel (make-channel session)))
+                   (channel-open-session channel)
+                   (channel-request-exec channel "echo hello > /root/witness")
+                   (and (zero? (channel-get-exit-status channel))
+                        (wait-for-file "/root/witness" marionette))))))
 
-          ;; Connect to the guest over SFTP.  Make sure we can write and
-          ;; read a file there.
-          (unless #$sftp?
-            (test-skip 1))
-          (test-equal "SFTP file writing and reading"
-            'hello
-            (call-with-connected-session/auth
-             (lambda (session)
-               (let ((sftp-session (make-sftp-session session))
-                     (witness "/root/sftp-witness"))
-                 (call-with-remote-output-file sftp-session witness
-                                               (cut display "hello" <>))
-                 (call-with-remote-input-file sftp-session witness
-                                              read)))))
+            ;; Connect to the guest over SFTP.  Make sure we can write and
+            ;; read a file there.
+            (unless #$sftp?
+              (test-skip 1))
+            (test-equal "SFTP file writing and reading"
+              'hello
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let ((sftp-session (make-sftp-session session))
+                       (witness "/root/sftp-witness"))
+                   (call-with-remote-output-file sftp-session witness
+                                                 (cut display "hello" <>))
+                   (call-with-remote-input-file sftp-session witness
+                                                read)))))
 
-          ;; Connect to the guest over SSH.  Make sure we can run commands
-          ;; from the system profile.
-          (test-equal "run executables from system profile"
-            #t
-            (call-with-connected-session/auth
-             (lambda (session)
-               (let ((channel (make-channel session)))
-                 (channel-open-session channel)
-                 (channel-request-exec
-                  channel
-                  (string-append
-                   "mkdir -p /root/.guix-profile/bin && "
-                   "touch /root/.guix-profile/bin/path-witness && "
-                   "chmod 755 /root/.guix-profile/bin/path-witness"))
-                 (zero? (channel-get-exit-status channel))))))
+            ;; Connect to the guest over SSH.  Make sure we can run commands
+            ;; from the system profile.
+            (test-equal "run executables from system profile"
+              #t
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let ((channel (make-channel session)))
+                   (channel-open-session channel)
+                   (channel-request-exec
+                    channel
+                    (string-append
+                     "mkdir -p /root/.guix-profile/bin && "
+                     "touch /root/.guix-profile/bin/path-witness && "
+                     "chmod 755 /root/.guix-profile/bin/path-witness"))
+                   (zero? (channel-get-exit-status channel))))))
 
-          ;; Connect to the guest over SSH.  Make sure we can run commands
-          ;; from the user profile.
-          (test-equal "run executable from user profile"
-            #t
-            (call-with-connected-session/auth
-             (lambda (session)
-               (let ((channel (make-channel session)))
-                 (channel-open-session channel)
-                 (channel-request-exec channel "path-witness")
-                 (zero? (channel-get-exit-status channel))))))
+            ;; Connect to the guest over SSH.  Make sure we can run commands
+            ;; from the user profile.
+            (test-equal "run executable from user profile"
+              #t
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let ((channel (make-channel session)))
+                   (channel-open-session channel)
+                   (channel-request-exec channel "path-witness")
+                   (zero? (channel-get-exit-status channel))))))
 
-          (test-end)
-          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+            (test-end)
+            (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
 
   (gexp->derivation name test))
 
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png'.
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions' Ludovic Courtès
@ 2018-05-28 21:59   ` Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions' Ludovic Courtès
                     ` (2 subsequent siblings)
  5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* gnu/bootloader/grub.scm (svg->png): Remove now unneeded
  #:guile-for-build argument.
---
 gnu/bootloader/grub.scm | 32 ++++++++++++++------------------
 1 file changed, 14 insertions(+), 18 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index eca6d97b1..e90a6a11e 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -121,25 +121,21 @@ otherwise."
 
 (define* (svg->png svg #:key width height)
   "Build a PNG of HEIGHT x WIDTH from SVG."
-  ;; Note: Guile-RSVG & co. are now built for Guile 2.2, so we use 2.2 here.
-  ;; TODO: Remove #:guile-for-build when 2.2 has become the default.
-  (mlet %store-monad ((guile (package->derivation guile-2.2 #:graft? #f)))
-    (gexp->derivation "grub-image.png"
-                      (with-imported-modules '((gnu build svg))
-                        #~(begin
-                            ;; We need these two libraries.
-                            (add-to-load-path (string-append #+guile-rsvg
-                                                             "/share/guile/site/"
-                                                             (effective-version)))
-                            (add-to-load-path (string-append #+guile-cairo
-                                                             "/share/guile/site/"
-                                                             (effective-version)))
+  (gexp->derivation "grub-image.png"
+                    (with-imported-modules '((gnu build svg))
+                      #~(begin
+                          ;; We need these two libraries.
+                          (add-to-load-path (string-append #+guile-rsvg
+                                                           "/share/guile/site/"
+                                                           (effective-version)))
+                          (add-to-load-path (string-append #+guile-cairo
+                                                           "/share/guile/site/"
+                                                           (effective-version)))
 
-                            (use-modules (gnu build svg))
-                            (svg->png #+svg #$output
-                                      #:width #$width
-                                      #:height #$height)))
-                      #:guile-for-build guile)))
+                          (use-modules (gnu build svg))
+                          (svg->png #+svg #$output
+                                    #:width #$width
+                                    #:height #$height)))))
 
 (define* (grub-background-image config #:key (width 1024) (height 768))
   "Return the GRUB background image defined in CONFIG with a ratio of
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions'.
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
                     ` (2 preceding siblings ...)
  2018-05-28 21:59   ` [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png' Ludovic Courtès
@ 2018-05-28 21:59   ` Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 6/7] profiles: " Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 7/7] vm: " Ludovic Courtès
  5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* gnu/bootloader/grub.scm (svg->png): Use 'with-extensions'.  Remove
'add-to-load-path' calls.
* gnu/build/svg.scm: Use (rsvg) and (cairo) the normal way.  Remove
'module-autoload!' calls.
---
 gnu/bootloader/grub.scm | 19 ++++++-------------
 gnu/build/svg.scm       | 11 +++--------
 2 files changed, 9 insertions(+), 21 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index e90a6a11e..a131f3b50 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -123,19 +123,12 @@ otherwise."
   "Build a PNG of HEIGHT x WIDTH from SVG."
   (gexp->derivation "grub-image.png"
                     (with-imported-modules '((gnu build svg))
-                      #~(begin
-                          ;; We need these two libraries.
-                          (add-to-load-path (string-append #+guile-rsvg
-                                                           "/share/guile/site/"
-                                                           (effective-version)))
-                          (add-to-load-path (string-append #+guile-cairo
-                                                           "/share/guile/site/"
-                                                           (effective-version)))
-
-                          (use-modules (gnu build svg))
-                          (svg->png #+svg #$output
-                                    #:width #$width
-                                    #:height #$height)))))
+                      (with-extensions (list guile-rsvg guile-cairo)
+                        #~(begin
+                            (use-modules (gnu build svg))
+                            (svg->png #+svg #$output
+                                      #:width #$width
+                                      #:height #$height))))))
 
 (define* (grub-background-image config #:key (width 1024) (height 768))
   "Return the GRUB background image defined in CONFIG with a ratio of
diff --git a/gnu/build/svg.scm b/gnu/build/svg.scm
index b5474ec4a..6f1f4b368 100644
--- a/gnu/build/svg.scm
+++ b/gnu/build/svg.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -18,16 +18,11 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build svg)
+  #:use-module (rsvg)
+  #:use-module (cairo)
   #:use-module (srfi srfi-11)
   #:export (svg->png))
 
-;; We need Guile-RSVG and Guile-Cairo.  Load them lazily, at run time, to
-;; allow compilation to proceed.  See also <http://bugs.gnu.org/12202>.
-(module-autoload! (current-module)
-                  '(rsvg) '(rsvg-handle-new-from-file))
-(module-autoload! (current-module)
-                  '(cairo) '(cairo-image-surface-create))
-
 (define* (downscaled-surface surface
                              #:key
                              source-width source-height
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 6/7] profiles: Use 'with-extensions'.
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
                     ` (3 preceding siblings ...)
  2018-05-28 21:59   ` [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions' Ludovic Courtès
@ 2018-05-28 21:59   ` Ludovic Courtès
  2018-05-28 21:59   ` [bug#31633] [PATCH 7/7] vm: " Ludovic Courtès
  5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* guix/profiles.scm (manual-database)[build]: Use 'with-extensions'.
Remove 'add-to-load-path' call.
* guix/man-db.scm: Use (gdbm) the normal way; remove 'module-autoload!'
call.
---
 guix/man-db.scm   |  6 ++---
 guix/profiles.scm | 60 +++++++++++++++++++++++------------------------
 2 files changed, 31 insertions(+), 35 deletions(-)

diff --git a/guix/man-db.scm b/guix/man-db.scm
index 732aef108..4cef874f8 100644
--- a/guix/man-db.scm
+++ b/guix/man-db.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +19,7 @@
 (define-module (guix man-db)
   #:use-module (guix zlib)
   #:use-module ((guix build utils) #:select (find-files))
+  #:use-module (gdbm)                             ;gdbm-ffi
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -44,9 +45,6 @@
 ;;;
 ;;; Code:
 
-;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co.
-(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT))
-
 (define-record-type <mandb-entry>
   (mandb-entry file-name name section synopsis kind)
   mandb-entry?
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fd7e5b922..9bddf8816 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1196,41 +1196,39 @@ the entries in MANIFEST."
 
   (define build
     (with-imported-modules modules
-      #~(begin
-          (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
-                                           (effective-version)))
+      (with-extensions (list gdbm-ffi)            ;for (guix man-db)
+        #~(begin
+            (use-modules (guix man-db)
+                         (guix build utils)
+                         (srfi srfi-1)
+                         (srfi srfi-19))
 
-          (use-modules (guix man-db)
-                       (guix build utils)
-                       (srfi srfi-1)
-                       (srfi srfi-19))
+            (define (compute-entries)
+              (append-map (lambda (directory)
+                            (let ((man (string-append directory "/share/man")))
+                              (if (directory-exists? man)
+                                  (mandb-entries man)
+                                  '())))
+                          '#$(manifest-inputs manifest)))
 
-          (define (compute-entries)
-            (append-map (lambda (directory)
-                          (let ((man (string-append directory "/share/man")))
-                            (if (directory-exists? man)
-                                (mandb-entries man)
-                                '())))
-                        '#$(manifest-inputs manifest)))
+            (define man-directory
+              (string-append #$output "/share/man"))
 
-          (define man-directory
-            (string-append #$output "/share/man"))
+            (mkdir-p man-directory)
 
-          (mkdir-p man-directory)
-
-          (format #t "Creating manual page database...~%")
-          (force-output)
-          (let* ((start    (current-time))
-                 (entries  (compute-entries))
-                 (_        (write-mandb-database (string-append man-directory
-                                                                "/index.db")
-                                                 entries))
-                 (duration (time-difference (current-time) start)))
-            (format #t "~a entries processed in ~,1f s~%"
-                    (length entries)
-                    (+ (time-second duration)
-                       (* (time-nanosecond duration) (expt 10 -9))))
-            (force-output)))))
+            (format #t "Creating manual page database...~%")
+            (force-output)
+            (let* ((start    (current-time))
+                   (entries  (compute-entries))
+                   (_        (write-mandb-database (string-append man-directory
+                                                                  "/index.db")
+                                                   entries))
+                   (duration (time-difference (current-time) start)))
+              (format #t "~a entries processed in ~,1f s~%"
+                      (length entries)
+                      (+ (time-second duration)
+                         (* (time-nanosecond duration) (expt 10 -9))))
+              (force-output))))))
 
   (gexp->derivation "manual-database" build
 
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 7/7] vm: Use 'with-extensions'.
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
                     ` (4 preceding siblings ...)
  2018-05-28 21:59   ` [bug#31633] [PATCH 6/7] profiles: " Ludovic Courtès
@ 2018-05-28 21:59   ` Ludovic Courtès
  5 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-28 21:59 UTC (permalink / raw)
  To: 31633

* gnu/system/vm.scm (system-docker-image)[build]: Use
'with-extensions'.  Remove 'add-to-load-path' calls.
---
 gnu/system/vm.scm | 93 +++++++++++++++++++++++------------------------
 1 file changed, 46 insertions(+), 47 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4cffc71d7..66c6773c6 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -411,58 +411,57 @@ should set REGISTER-CLOSURES? to #f."
                      (eval-when (expand load eval)
                        (define %libgcrypt
                          #+(file-append libgcrypt "/lib/libgcrypt"))))))
+
   (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
                       (name -> (string-append name ".tar.gz"))
                       (graph -> "system-graph"))
     (define build
-      (with-imported-modules `(,@(source-module-closure '((guix docker)
-                                                          (guix build utils)
-                                                          (gnu build vm))
-                                                        #:select? not-config?)
-                               (guix build store-copy)
-                               ((guix config) => ,config))
-        #~(begin
-            ;; Guile-JSON is required by (guix docker).
-            (add-to-load-path
-             (string-append #+guile-json "/share/guile/site/"
-                            (effective-version)))
-            (use-modules (guix docker)
-                         (guix build utils)
-                         (gnu build vm)
-                         (srfi srfi-19)
-                         (guix build store-copy))
+      (with-extensions (list guile-json)          ;for (guix docker)
+        (with-imported-modules `(,@(source-module-closure
+                                    '((guix docker)
+                                      (guix build utils)
+                                      (gnu build vm))
+                                    #:select? not-config?)
+                                 (guix build store-copy)
+                                 ((guix config) => ,config))
+          #~(begin
+              (use-modules (guix docker)
+                           (guix build utils)
+                           (gnu build vm)
+                           (srfi srfi-19)
+                           (guix build store-copy))
 
-            (let* ((inputs '#$(append (list tar)
-                                      (if register-closures?
-                                          (list guix)
-                                          '())))
-                   ;; This initializer requires elevated privileges that are
-                   ;; not normally available in the build environment (e.g.,
-                   ;; it needs to create device nodes).  In order to obtain
-                   ;; such privileges, we run it as root in a VM.
-                   (initialize (root-partition-initializer
-                                #:closures '(#$graph)
-                                #:register-closures? #$register-closures?
-                                #:system-directory #$os-drv
-                                ;; De-duplication would fail due to
-                                ;; cross-device link errors, so don't do it.
-                                #:deduplicate? #f))
-                   ;; Even as root in a VM, the initializer would fail due to
-                   ;; lack of privileges if we use a root-directory that is on
-                   ;; a file system that is shared with the host (e.g., /tmp).
-                   (root-directory "/guixsd-system-root"))
-              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-              (mkdir root-directory)
-              (initialize root-directory)
-              (build-docker-image
-               (string-append "/xchg/" #$name) ;; The output file.
-               (cons* root-directory
-                      (call-with-input-file (string-append "/xchg/" #$graph)
-                        read-reference-graph))
-               #$os-drv
-               #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
-               #:creation-time (make-time time-utc 0 1)
-               #:transformations `((,root-directory -> "")))))))
+              (let* ((inputs '#$(append (list tar)
+                                        (if register-closures?
+                                            (list guix)
+                                            '())))
+                     ;; This initializer requires elevated privileges that are
+                     ;; not normally available in the build environment (e.g.,
+                     ;; it needs to create device nodes).  In order to obtain
+                     ;; such privileges, we run it as root in a VM.
+                     (initialize (root-partition-initializer
+                                  #:closures '(#$graph)
+                                  #:register-closures? #$register-closures?
+                                  #:system-directory #$os-drv
+                                  ;; De-duplication would fail due to
+                                  ;; cross-device link errors, so don't do it.
+                                  #:deduplicate? #f))
+                     ;; Even as root in a VM, the initializer would fail due to
+                     ;; lack of privileges if we use a root-directory that is on
+                     ;; a file system that is shared with the host (e.g., /tmp).
+                     (root-directory "/guixsd-system-root"))
+                (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+                (mkdir root-directory)
+                (initialize root-directory)
+                (build-docker-image
+                 (string-append "/xchg/" #$name) ;; The output file.
+                 (cons* root-directory
+                        (call-with-input-file (string-append "/xchg/" #$graph)
+                          read-reference-graph))
+                 #$os-drv
+                 #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
+                 #:creation-time (make-time time-utc 0 1)
+                 #:transformations `((,root-directory -> ""))))))))
     (expression->derivation-in-linux-vm
      name
      ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp
-- 
2.17.0

^ permalink raw reply related	[flat|nested] 10+ messages in thread

* [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps
  2018-05-28 21:56 [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Ludovic Courtès
  2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
@ 2018-06-01  7:37 ` Danny Milosavljevic
  2018-06-01 13:42   ` bug#31633: " Ludovic Courtès
  1 sibling, 1 reply; 10+ messages in thread
From: Danny Milosavljevic @ 2018-06-01  7:37 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: 31633

[-- Attachment #1: Type: text/plain, Size: 45 bytes --]

Hi Ludo,

good idea.

This series LGTM!

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 488 bytes --]

^ permalink raw reply	[flat|nested] 10+ messages in thread

* bug#31633: [PATCH 0/7] Add 'with-extensions' for gexps
  2018-06-01  7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic
@ 2018-06-01 13:42   ` Ludovic Courtès
  0 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-06-01 13:42 UTC (permalink / raw)
  To: Danny Milosavljevic; +Cc: 31633-done

Hello,

Danny Milosavljevic <dannym@scratchpost.org> skribis:

> good idea.
>
> This series LGTM!

Thanks, I’ve pushed it now!

Ludo’.

^ permalink raw reply	[flat|nested] 10+ messages in thread

end of thread, other threads:[~2018-06-01 13:43 UTC | newest]

Thread overview: 10+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2018-05-28 21:56 [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Ludovic Courtès
2018-05-28 21:59 ` [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions' Ludovic Courtès
2018-05-28 21:59   ` [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker) Ludovic Courtès
2018-05-28 21:59   ` [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions' Ludovic Courtès
2018-05-28 21:59   ` [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png' Ludovic Courtès
2018-05-28 21:59   ` [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions' Ludovic Courtès
2018-05-28 21:59   ` [bug#31633] [PATCH 6/7] profiles: " Ludovic Courtès
2018-05-28 21:59   ` [bug#31633] [PATCH 7/7] vm: " Ludovic Courtès
2018-06-01  7:37 ` [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps Danny Milosavljevic
2018-06-01 13:42   ` bug#31633: " Ludovic Courtès

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).