summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorRicardo Wurmus <rekado@elephly.net>2017-08-27 17:38:47 +0200
committerRicardo Wurmus <rekado@elephly.net>2017-09-28 13:10:11 +0200
commit5e892bc365a3da0d30a0982783ee2ab82ee090f8 (patch)
tree797c11fb7cd00954c4077f383c43792d1278312b /guix
parent68a91a183b29c62232fb048bb27e10b6ff2e39dd (diff)
import: Add generic data to package converter.
* guix/import/utils.scm (build-system-modules, lookup-build-system-by-name, specs->package-lists, source-spec->object, alist->package): New procedures. * tests/import-utils.scm: Add tests for alist->package.
Diffstat (limited to 'guix')
-rw-r--r--guix/import/utils.scm90
1 files changed, 89 insertions, 1 deletions
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))))))