From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:39937) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d2l6q-0003S2-Tv for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:30 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d2l6l-0003zp-Rf for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:24 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40315) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d2l6l-0003zd-M0 for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:19 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d2l6l-0004e4-CA for guix-patches@gnu.org; Mon, 24 Apr 2017 17:01:19 -0400 Subject: bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package. Resent-Message-ID: From: Andy Wingo Date: Mon, 24 Apr 2017 22:59:21 +0200 Message-Id: <20170424205923.27726-7-wingo@igalia.com> In-Reply-To: <20170424205923.27726-1-wingo@igalia.com> References: <20170424205923.27726-1-wingo@igalia.com> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26645@debbugs.gnu.org * 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