From: Andy Wingo <wingo@igalia.com>
To: 26645@debbugs.gnu.org
Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package.
Date: Mon, 24 Apr 2017 22:59:21 +0200 [thread overview]
Message-ID: <20170424205923.27726-7-wingo@igalia.com> (raw)
In-Reply-To: <20170424205923.27726-1-wingo@igalia.com>
* guix/potluck/packages.scm (lower-potluck-package-to-module): New public
function.
---
guix/potluck/packages.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 117 insertions(+), 1 deletion(-)
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index 3bf2d67c1..3c7a1ca49 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -29,8 +29,10 @@
#:use-module (guix potluck licenses)
#:use-module (guix records)
#:use-module (guix utils)
+ #:use-module ((guix ui) #:select (package-specification->name+version+output))
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
+ #:use-module ((srfi srfi-1) #:select (concatenate delete-duplicates))
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -67,7 +69,9 @@
validate-potluck-package
lower-potluck-source
- lower-potluck-package))
+ lower-potluck-package
+
+ lower-potluck-package-to-module))
;;; Commentary:
;;;
@@ -456,3 +460,115 @@ potluck package will be validated with @code{validate-potluck-package}."
(synopsis synopsis)
(description description)
(license (license-by-name license)))))
+
+(define (lower-potluck-package-to-module port lowered-module-name pkg)
+ (let ((lowered (lower-potluck-package pkg))
+ ;; specification -> exp
+ (spec->binding (make-hash-table))
+ ;; mod-name -> (sym ...)
+ (imports (make-hash-table))
+ ;; sym -> specification
+ (imported-syms (make-hash-table))
+ (needs-runtime-lookup? #f))
+ (define (add-bindings spec)
+ (unless (hash-ref spec->binding spec)
+ (match (false-if-exception (lower-input spec))
+ ((name pkg . outputs)
+ ;; Given that we found the pkg, surely we should find its binding
+ ;; also.
+ (call-with-values (lambda () (find-package-binding pkg))
+ (lambda (module-name sym)
+ ;; Currently we import these bindings using their original
+ ;; names. We need to make sure that names don't collide.
+ ;; Ideally we should also ensure that they don't collide with
+ ;; other bindings that we import.
+ (when (hashq-ref imported-syms sym)
+ (error "duplicate import name" sym))
+ (hashq-set! imported-syms sym spec)
+ (hash-set! spec->binding spec
+ `(list ,name ,sym . ,outputs))
+ (hash-set! imports module-name
+ (cons sym (hash-ref imports module-name '()))))))
+ (#f
+ (warn "could not resolve package specification" spec)
+ (call-with-values
+ (lambda ()
+ (package-specification->name+version+output spec))
+ (lambda (name version . outputs)
+ (hash-set! spec->binding spec
+ `(list ,name (specification->package ,spec) .
+ ,(if (equal? outputs '("out")) '() outputs)))
+ (set! needs-runtime-lookup? #t)))))))
+
+ (for-each add-bindings (potluck-package-inputs pkg))
+ (for-each add-bindings (potluck-package-native-inputs pkg))
+ (for-each add-bindings (potluck-package-propagated-inputs pkg))
+
+ (format port "(define-module ~a" lowered-module-name)
+ (format port "~% #:pure")
+ ;; Because we're pure, we have to import these.
+ (format port "~% #:use-module ((guile) #:select (list quote define-public))")
+ (when needs-runtime-lookup?
+ (format port "~% #:use-module ((gnu packages) #:select (specification->package))"))
+ (format port "~% #:use-module ((guix packages) #:select (package origin base32))")
+ (format port "~% #:use-module ((guix git-download) #:select (git-fetch git-reference))")
+ (format port "~% #:use-module ((guix licenses) #:select ((~a . license:~a)))"
+ (potluck-package-license pkg) (potluck-package-license pkg))
+ (format port "~% #:use-module ((guix build-system ~a) #:select (~a-build-system))"
+ (potluck-package-build-system pkg) (potluck-package-build-system pkg))
+ (for-each (match-lambda
+ ((module-name . syms)
+ (format port "~% #:use-module (~a #:select ~a)"
+ module-name syms)))
+ (hash-map->list cons imports))
+ (format port ")~%~%")
+
+ (format port "(define-public ~s\n" (string->symbol
+ (potluck-package-name pkg)))
+ (format port " (package\n")
+ (format port " (name ~s)\n" (potluck-package-name pkg))
+ (format port " (version ~s)\n" (potluck-package-version pkg))
+ (format port " (source\n")
+
+ (let ((source (potluck-package-source pkg)))
+ (format port " (origin\n")
+ (format port " (method git-fetch)\n")
+ (format port " (uri (git-reference\n")
+ (format port " (url ~s)\n" (potluck-source-git-uri source))
+ (format port " (commit ~s)))\n"
+ (potluck-source-git-commit source))
+ (when (potluck-source-snippet source)
+ (pretty-print `(snippet ',(potluck-source-snippet source)) port
+ #:per-line-prefix " "))
+ (format port " (sha256 (base32 ~s))))\n"
+ (potluck-source-sha256 source)))
+
+ (format port " (build-system ~s-build-system)\n"
+ (potluck-package-build-system pkg))
+
+ (for-each
+ (match-lambda
+ ((name)
+ ;; No inputs; do nothing.
+ #t)
+ ((name . specs)
+ (pretty-print
+ `(,name (list ,@(map (lambda (spec)
+ (or (hash-ref spec->binding spec)
+ (error "internal error" spec)))
+ specs)))
+ port #:per-line-prefix " ")))
+ `((inputs . ,(potluck-package-inputs pkg))
+ (native-inputs . ,(potluck-package-native-inputs pkg))
+ (propagated-inputs . ,(potluck-package-propagated-inputs pkg))))
+
+ (match (potluck-package-arguments pkg)
+ (() #t)
+ (arguments
+ (pretty-print `(arguments ',arguments) port #:per-line-prefix " ")))
+
+ (format port " (home-page ~s)\n" (potluck-package-home-page pkg))
+ (format port " (synopsis ~s)\n" (potluck-package-synopsis pkg))
+ (format port " (description ~s)\n" (potluck-package-description pkg))
+ (format port " (license license:~s)))\n" (potluck-package-license pkg))
+ (force-output port)))
--
2.12.2
next prev parent reply other threads:[~2017-04-24 21:01 UTC|newest]
Thread overview: 24+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-04-24 20:53 bug#26645: guix potluck Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 3/9] guix: Add git utility module Andy Wingo
2017-05-03 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 4/9] guix: Add "potluck" command Andy Wingo
2017-05-04 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox Andy Wingo
2017-05-04 20:27 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 6/9] gnu: Add find-package-binding Andy Wingo
2017-05-04 20:29 ` Ludovic Courtès
2017-04-24 20:59 ` Andy Wingo [this message]
2017-05-04 20:31 ` bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand Andy Wingo
2017-05-04 20:55 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 9/9] doc: Document guix potluck Andy Wingo
2017-05-04 20:56 ` Ludovic Courtès
2017-05-03 20:19 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Ludovic Courtès
2017-05-03 21:55 ` Ludovic Courtès
2017-04-24 21:09 ` bug#26645: guix potluck ng0
2020-03-18 20:03 ` [bug#26645] Potluck still relivant Jack Hill
2020-04-01 16:11 ` Brice Waegeneire
2020-04-29 6:02 ` Ricardo Wurmus
2023-07-21 16:57 ` bug#26645: guix potluck Maxim Cournoyer
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20170424205923.27726-7-wingo@igalia.com \
--to=wingo@igalia.com \
--cc=26645@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).