diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/print.scm | 164 | ||||
| -rw-r--r-- | guix/import/utils.scm | 90 |
2 files changed, 253 insertions, 1 deletions
diff --git a/guix/import/print.scm b/guix/import/print.scm new file mode 100644 index 0000000000..0bec32c8dc --- /dev/null +++ b/guix/import/print.scm @@ -0,0 +1,164 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix import print) + #:use-module (guix base32) + #:use-module (guix utils) + #:use-module (guix licenses) + #:use-module (guix packages) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (guix import utils) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:export (package->code)) + +;; FIXME: the quasiquoted arguments field may contain embedded package +;; objects, e.g. in #:disallowed-references; they will just be printed with +;; their usual #<package ...> representation, not as variable names. +(define (package->code package) + "Return an S-expression representing the source code that produces PACKAGE +when evaluated." + ;; The module in which the package PKG is defined + (define (package-module-name pkg) + (map string->symbol + (string-split (string-drop-right + (location-file (package-location pkg)) 4) + #\/))) + + ;; Return the first candidate variable name that is bound to VAL. + (define (variable-name val mod) + (match (let/ec return + (module-for-each (lambda (sym var) + (if (eq? val (variable-ref var)) + (return sym) + #f)) + (resolve-interface mod))) + ((? symbol? sym) sym) + (_ #f))) + + ;; Print either license variable name or the code for a license object + (define (license->code lic) + (let ((var (variable-name lic '(guix licenses)))) + (or var + `(license + (name ,(license-name lic)) + (uri ,(license-uri lic)) + (comment ,(license-comment lic)))))) + + (define (search-path-specification->code spec) + `(search-path-specification + (variable ,(search-path-specification-variable spec)) + (files (list ,@(search-path-specification-files spec))) + (separator ,(search-path-specification-separator spec)) + (file-type (quote ,(search-path-specification-file-type spec))) + (file-pattern ,(search-path-specification-file-pattern spec)))) + + (define (source->code source version) + (let ((uri (origin-uri source)) + (method (origin-method source)) + (sha256 (origin-sha256 source)) + (file-name (origin-file-name source)) + (patches (origin-patches source))) + `(origin + (method ,(procedure-name method)) + (uri (string-append ,@(factorize-uri uri version))) + (sha256 + (base32 + ,(format #f "~a" (bytevector->nix-base32-string sha256)))) + ;; FIXME: in order to be able to throw away the directory prefix, + ;; we just assume that the patch files can be found with + ;; "search-patches". + ,@(if (null? patches) '() + `((patches (search-patches ,@(map basename patches)))))))) + + (define (package-lists->code lsts) + (list 'quasiquote + (map (match-lambda + ((label pkg . out) + (let ((mod (package-module-name pkg))) + (list label + ;; FIXME: using '@ certainly isn't pretty, but it + ;; avoids having to import the individual package + ;; modules. + (list 'unquote + (list '@ mod (variable-name pkg mod))))))) + lsts))) + + (let ((name (package-name package)) + (version (package-version package)) + (source (package-source package)) + (build-system (package-build-system package)) + (arguments (package-arguments package)) + (inputs (package-inputs package)) + (propagated-inputs (package-propagated-inputs package)) + (native-inputs (package-native-inputs package)) + (outputs (package-outputs package)) + (native-search-paths (package-native-search-paths package)) + (search-paths (package-search-paths package)) + (replacement (package-replacement package)) + (synopsis (package-synopsis package)) + (description (package-description package)) + (license (package-license package)) + (home-page (package-home-page package)) + (supported-systems (package-supported-systems package)) + (properties (package-properties package))) + `(package + (name ,name) + (version ,version) + (source ,(source->code source version)) + ,@(match properties + (() '()) + (_ `((properties ,properties)))) + ,@(if replacement + `((replacement ,replacement)) + '()) + (build-system ,(symbol-append (build-system-name build-system) + '-build-system)) + ,@(match arguments + (() '()) + (args `((arguments ,(list 'quasiquote args))))) + ,@(match outputs + (("out") '()) + (outs `((outputs (list ,@outs))))) + ,@(match native-inputs + (() '()) + (pkgs `((native-inputs ,(package-lists->code pkgs))))) + ,@(match inputs + (() '()) + (pkgs `((inputs ,(package-lists->code pkgs))))) + ,@(match propagated-inputs + (() '()) + (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + ,@(if (lset= string=? supported-systems %supported-systems) + '() + `((supported-systems (list ,@supported-systems)))) + ,@(match (map search-path-specification->code native-search-paths) + (() '()) + (paths `((native-search-paths (list ,@paths))))) + ,@(match (map search-path-specification->code search-paths) + (() '()) + (paths `((search-paths (list ,@paths))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(if (list? license) + `(list ,@(map license->code license)) + (license->code license)))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index be1980d08f..1e2f0c809d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,9 +26,17 @@ #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix discovery) + #:use-module (guix build-system) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix download) + #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:export (factorize-uri hash-table->alist @@ -45,7 +54,9 @@ license->symbol snake-case - beautify-description)) + beautify-description + + alist->package)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -241,3 +252,80 @@ package definition." (('package ('name (? string? name)) _ ...) `(define-public ,(string->symbol name) ,guix-package)))) + +(define (build-system-modules) + (all-modules (map (lambda (entry) + `(,entry . "guix/build-system")) + %load-path))) + +(define (lookup-build-system-by-name name) + "Return a <build-system> value for the symbol NAME, representing the name of +the build system." + (fold-module-public-variables (lambda (obj result) + (if (and (build-system? obj) + (eq? name (build-system-name obj))) + obj result)) + #f + (build-system-modules))) + +(define (specs->package-lists specs) + "Convert each string in the SPECS list to a list of a package label and a +package value." + (map (lambda (spec) + (let-values (((pkg out) (specification->package+output spec))) + (match out + (("out") (list (package-name pkg) pkg)) + (_ (list (package-name pkg) pkg out))))) + specs)) + +(define (source-spec->object source) + "Generate an <origin> object from a SOURCE specification. The SOURCE can +either be a simple URL string, #F, or an alist containing entries for each of +the expected fields of an <origin> object." + (match source + ((? string? source-url) + (let ((tarball (with-store store (download-to-store store source-url)))) + (origin + (method url-fetch) + (uri source-url) + (sha256 (base32 (guix-hash-url tarball)))))) + (#f #f) + (orig (let ((sha (match (assoc-ref orig "sha256") + ((("base32" . value)) + (base32 value)) + (_ #f)))) + (origin + (method (match (assoc-ref orig "method") + ("url-fetch" (@ (guix download) url-fetch)) + ("git-fetch" (@ (guix git-download) git-fetch)) + ("svn-fetch" (@ (guix svn-download) svn-fetch)) + ("hg-fetch" (@ (guix hg-download) hg-fetch)) + (_ #f))) + (uri (assoc-ref orig "uri")) + (sha256 sha)))))) + +(define (alist->package meta) + (package + (name (assoc-ref meta "name")) + (version (assoc-ref meta "version")) + (source (source-spec->object (assoc-ref meta "source"))) + (build-system + (lookup-build-system-by-name + (string->symbol (assoc-ref meta "build-system")))) + (native-inputs + (specs->package-lists (or (assoc-ref meta "native-inputs") '()))) + (inputs + (specs->package-lists (or (assoc-ref meta "inputs") '()))) + (propagated-inputs + (specs->package-lists (or (assoc-ref meta "propagated-inputs") '()))) + (home-page + (assoc-ref meta "home-page")) + (synopsis + (assoc-ref meta "synopsis")) + (description + (assoc-ref meta "description")) + (license + (let ((l (assoc-ref meta "license"))) + (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) + (spdx-string->license l)) + (license:fsdg-compatible l)))))) |