| Message ID | 20210621061205.31878-5-maxim.cournoyer@gmail.com |
|---|---|
| State | Accepted |
| Headers | show |
| Series | [bug#49149] tentatively reuse rlib for cargo-build-system | expand |
| Context | Check | Description |
|---|---|---|
| cbaines/comparison | success | View comparision |
| cbaines/git branch | success | View Git branch |
| cbaines/applying patch | fail | View Laminar job |
| cbaines/issue | success | View issue |
Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]: > Instead of just naming them by their pack type, add information from the > package(s) they contain to make it easier to differentiate them. > > * guix/scripts/pack.scm (manifest->friendly-name): Extract procedure from ... > (docker-image): ... here. Adjust REPOSITORY argument value accordingly. > (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME. > --- > guix/scripts/pack.scm | 44 +++++++++++++++++++++++++------------------ > 1 file changed, 26 insertions(+), 18 deletions(-) > > diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm > index 7ea97a4b7a..9d4bb9f497 100644 > --- a/guix/scripts/pack.scm > +++ b/guix/scripts/pack.scm > @@ -172,6 +172,23 @@ dependencies are registered." > (computed-file "store-database" build > #:options `(#:references-graphs ,(zip labels items)))) > > +;;; XXX: The following procedure has to *also* be used in the build side > +;;; G-Exp, because PROFILE is passed as a derivation in the tests. > +(define define-manifest->friendly-name > + '(define (manifest->friendly-name manifest) [...])) > > +(eval define-manifest->friendly-name (current-module)) You can avoid 'eval' here by defining 'manifest->friendly-name in a separate guix/build/pack-utils.scm module. Alternatively, some macroology (untested, may need some tweaks): (define-syntax define-gexp-and-expand ((_ variable code code* ...) (begin (define variable #~(code code* ...)) code code* ...))) (define-gexp-and-expand define-manifest->friendly-name (define (manifest->friendly-name manifest) [... docstring] [... all the code])) Greetings, Maxime.
Hello Maxime, Maxime Devos <maximedevos@telenet.be> writes: > Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]: >> Instead of just naming them by their pack type, add information from the >> package(s) they contain to make it easier to differentiate them. >> >> * guix/scripts/pack.scm (manifest->friendly-name): Extract procedure from ... >> (docker-image): ... here. Adjust REPOSITORY argument value accordingly. >> (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME. >> --- >> guix/scripts/pack.scm | 44 +++++++++++++++++++++++++------------------ >> 1 file changed, 26 insertions(+), 18 deletions(-) >> >> diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm >> index 7ea97a4b7a..9d4bb9f497 100644 >> --- a/guix/scripts/pack.scm >> +++ b/guix/scripts/pack.scm >> @@ -172,6 +172,23 @@ dependencies are registered." >> (computed-file "store-database" build >> #:options `(#:references-graphs ,(zip labels items)))) >> >> +;;; XXX: The following procedure has to *also* be used in the build side >> +;;; G-Exp, because PROFILE is passed as a derivation in the tests. >> +(define define-manifest->friendly-name >> + '(define (manifest->friendly-name manifest) [...])) >> >> +(eval define-manifest->friendly-name (current-module)) > > You can avoid 'eval' here by defining 'manifest->friendly-name > in a separate guix/build/pack-utils.scm module. > Alternatively, some macroology (untested, may need some tweaks): Thanks for the feedback! I tried moving 'manifest->friendly-name' to (guix build pack), which was already added in an earlier commit, but that didn't work because (guix profiles) needs to be pulled in for 'manifest-entries' and 'manifest-entry-name', and sadly (guix profiles) pulls (guix config), which is not possible/desirable on the build side. > (define-syntax define-gexp-and-expand > ((_ variable code code* ...) > (begin (define variable #~(code code* ...)) > code code* ...))) > > (define-gexp-and-expand define-manifest->friendly-name > (define (manifest->friendly-name manifest) > [... docstring] > [... all the code])) I'm not sure how the expansion would be usable in the module it is defined? It seems I could manage to get 'manifest->friendly-name' to be a procedure returning a gexp, but that gexp wouldn't be readily usable in that module (it could only be used when gexp-unquote from inside another G-Exp), and the expansion in the macro above doesn't bind any identifier, unless I'm missing something? So for now, I'm stuck with the eval, which doesn't seem to bad considering it's only evaluating a safe, static expression. Thank you, Maxim
> I'm not sure how the expansion would be usable in the module it is > defined? It seems I could manage to get 'manifest->friendly-name' to be > a procedure returning a gexp, but that gexp wouldn't be readily usable > in that module (it could only be used when gexp-unquote from inside > another G-Exp), and the expansion in the macro above doesn't bind any > identifier, unless I'm missing something? The macro does two things: define a procedure manifest->friendly-name that returns a string. (define (manifest->friendly-name manifest) "Return a friendly name computed from the entries in MANIFEST, a <manifest> object." (let loop ((names (map manifest-entry-name (manifest-entries manifest)))) (define str (string-join names "-")) (if (< (string-length str) 40) str (match names ((_) str) ((names ... _) (loop names))))))) ;drop one entry and also define a G-exp define-manifest->friendly-name (define define-manifest->friendly-nam #~(define (manifest->friendly-name manifes) "Return a friendly name [...]" [...]) Testing from a REPL: $ guix repl (use-modules (guix gexp) (ice-9 match) (guix profiles)) (define-syntax define-gexp-and-expand (syntax-rules () ((_ variable code) ; code* ... turned out to be unnecessary (begin (define variable #~code) code)))) (define-gexp-and-expand define-manifest->friendly-name (define (manifest->friendly-name manifest) "Return a friendly name computed from the entries in MANIFEST, a <manifest> object." (let loop ((names (map manifest-entry-name (manifest-entries manifest)))) (define str (string-join names "-")) (if (< (string-length str) 40) str (match names ((_) str) ((names ... _) (loop names))))))) ;drop one entry $ define-manifest->friendly-name $3 = #<gexp (define (manifest->friendly-name manifest) "Return a friendly name computed from the entries in MANIFEST, a\n <manifest> object." (let loop ((names (map manifest-entry-name (manifest- entries manifest)))) (define str (string-join names "-")) (if (< (string-length str) 40) str (match names ((_) str) ((names ... _) (loop names)))))) 7f4b3c5ee5a0> $ (manifest->friendly-name (specifications->manifest '("guile"))) $8 = "guile" Seems to work. Greetings, Maxime.
Hi, Maxime Devos <maximedevos@telenet.be> skribis: > Maxim Cournoyer schreef op ma 21-06-2021 om 02:12 [-0400]: [...] >> +;;; XXX: The following procedure has to *also* be used in the build side >> +;;; G-Exp, because PROFILE is passed as a derivation in the tests. >> +(define define-manifest->friendly-name >> + '(define (manifest->friendly-name manifest) [...])) >> >> +(eval define-manifest->friendly-name (current-module)) > > You can avoid 'eval' here by defining 'manifest->friendly-name > in a separate guix/build/pack-utils.scm module. Seconded! > Alternatively, some macroology (untested, may need some tweaks): See also ‘define-os-with-source’ in (gnu tests). HTH, Ludo’.
Hello Maxime & Ludovic, Maxime Devos <maximedevos@telenet.be> writes: >> I'm not sure how the expansion would be usable in the module it is >> defined? It seems I could manage to get 'manifest->friendly-name' to be >> a procedure returning a gexp, but that gexp wouldn't be readily usable >> in that module (it could only be used when gexp-unquote from inside >> another G-Exp), and the expansion in the macro above doesn't bind any >> identifier, unless I'm missing something? > > The macro does two things: define a procedure manifest->friendly-name > that returns a string. > > (define (manifest->friendly-name manifest) > "Return a friendly name computed from the entries in MANIFEST, a > <manifest> object." > (let loop ((names (map manifest-entry-name > (manifest-entries manifest)))) > (define str (string-join names "-")) > (if (< (string-length str) 40) > str > (match names > ((_) str) > ((names ... _) (loop names))))))) ;drop one entry > > and also define a G-exp define-manifest->friendly-name > > (define define-manifest->friendly-nam > #~(define (manifest->friendly-name manifes) > "Return a friendly name [...]" > [...]) Thanks a lot for persevering in your explanations, that made it clear and with some ideas from the fine folks in #guile was able to come up with this: --8<---------------cut here---------------start------------->8--- (define-syntax-rule (define-with-source (variable args ...) body body* ...) "Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting its source property." (begin (define (variable args ...) body) (eval-when (load eval) (set-procedure-property! variable 'source '(define (variable args ...) body body* ...))))) (define-with-source (manifest->friendly-name manifest) "Return a friendly name computed from the entries in MANIFEST, a <manifest> object." (let loop ((names (map manifest-entry-name (manifest-entries manifest)))) (define str (string-join names "-")) (if (< (string-length str) 40) str (match names ((_) str) ((names ... _) (loop names)))))) --8<---------------cut here---------------end--------------->8--- And then use it inside the build G-Exp via: #$(procedure-source manifest->friendly-name) The pack tests are still passing. Maxim
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7ea97a4b7a..9d4bb9f497 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -172,6 +172,23 @@ dependencies are registered." (computed-file "store-database" build #:options `(#:references-graphs ,(zip labels items)))) +;;; XXX: The following procedure has to *also* be used in the build side +;;; G-Exp, because PROFILE is passed as a derivation in the tests. +(define define-manifest->friendly-name + '(define (manifest->friendly-name manifest) + "Return a friendly name computed from the entries in MANIFEST, a +<manifest> object." + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names))))))) ;drop one entry + +(eval define-manifest->friendly-name (current-module)) + ;;; ;;; Tarball format. @@ -540,7 +557,7 @@ the image." (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define defmod 'define-module) ;trick Geiser + (define defmod 'define-module) ;trick Geiser (define build ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). @@ -558,6 +575,8 @@ the image." (srfi srfi-1) (srfi srfi-19) (ice-9 match)) + #$define-manifest->friendly-name + (define environment (map (match-lambda ((spec . value) @@ -581,19 +600,6 @@ the image." `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) - (define tag - ;; Compute a meaningful "repository" name, which will show up in - ;; the output of "docker images". - (let ((manifest (profile-manifest #$profile))) - (let loop ((names (map manifest-entry-name - (manifest-entries manifest)))) - (define str (string-join names "-")) - (if (< (string-length str) 40) - str - (match names - ((_) str) - ((names ... _) (loop names))))))) ;drop one entry - (setenv "PATH" #+(file-append archiver "/bin")) (build-docker-image #$output @@ -601,7 +607,8 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile - #:repository tag + #:repository (manifest->friendly-name + (profile-manifest #$profile)) #:database #+database #:system (or #$target %host-type) #:environment environment @@ -1209,8 +1216,6 @@ Create a bundle of PACKAGE.\n")) manifest) manifest))) (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1244,7 +1249,10 @@ Create a bundle of PACKAGE.\n")) (hooks (if bootstrap? '() %default-profile-hooks)) - (locales? (not bootstrap?))))) + (locales? (not bootstrap?)))) + (name (string-append (manifest->friendly-name manifest) + "-" (symbol->string pack-format) + "-pack"))) (define (lookup-package package) (manifest-lookup manifest (manifest-pattern (name package))))