From eeffdf569c4d7fbfd843e0b48404b6a2f3d46343 Mon Sep 17 00:00:00 2001
From: Martin Becze
Date: Mon, 16 Dec 2019 17:08:16 -0500
Subject: [PATCH 1/4] guix: import: added recusive-import-semver
* guix/import/utils.scm (recusive-import-semver): New Varible
* guix/import/utils.scm (package->definition)[arguments]: Add append-verions option
---
guix/import/utils.scm | 168 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 161 insertions(+), 7 deletions(-)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index d17d400ddf..7f75f50e23 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2017, 2019 Ricardo Wurmus
;;; Copyright © 2018 Oleg Pykhalov
;;; Copyright © 2019 Robert Vollmert
+;;; Copyright © 2019 Martin Becze
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,10 +41,13 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
+ #:use-module (semver)
+ #:use-module (semver ranges)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:export (factorize-uri
flatten
@@ -70,7 +74,8 @@
guix-name
- recursive-import))
+ recursive-import
+ recursive-import-semver))
(define (factorize-uri uri version)
"Factorize URI, a package tarball URI as a string, such that any occurrences
@@ -258,13 +263,13 @@ package definition."
((package-inputs ...)
`((native-inputs (,'quasiquote ,package-inputs))))))
-(define (package->definition guix-package)
+(define* (package->definition guix-package #:optional append-version?)
(match guix-package
- (('package ('name (? string? name)) _ ...)
- `(define-public ,(string->symbol name)
- ,guix-package))
- (('let anything ('package ('name (? string? name)) _ ...))
- `(define-public ,(string->symbol name)
+ ((or ('package ('name name) ('version version) . rest)
+ ('let _ ('package ('name name) ('version version) . rest)))
+ `(define-public ,(string->symbol (if append-version?
+ (string-append name "-" version)
+ version))
,guix-package))))
(define (build-system-modules)
@@ -428,3 +433,152 @@ name corresponding to the upstream name."
(remove exists?
(node-dependencies node))))
node-name)))
+
+(define* (recursive-import-semver #:key
+ name
+ (range "*")
+ name->metadata
+ metadata->package
+ metadata-versions
+ package-dependencies
+ dependency-name
+ dependency-range
+ guix-name
+ make-sexp)
+ "Generates a list of package expressions for the dependencies of the given
+NAME and version RANGE. The dependencies will be resolved using semantic versioning.
+This procedure makes the assumption that most package repositories will, for a
+given package provide some on that package that includes what
+versions of the package that are available and a list of dependencies for each
+version. Dependencies are assumed to be composed of a NAME, a semantic RANGE and
+other data.
+
+This procedure takes the following keys:
+ NAME - The name of the package to import
+ RANGE - The version range of the package to import
+ NAME->METADATA - A procedure that takes a NAME of a package and returns that
+package's
+ METADATA->PACKAGE A procedure that takes a package's and VERSION
+and returns the for the given VERSION
+ METADATA-VERSIONS A procedure that that takes a packages and
+returns a list of version as strings that are available for the given package
+ PACKAGE-DEPENDENCIES a procedure that returns a list of given a
+
+ DEPENDENCY-NAME A procedure that takes a and returns the its name
+ DEPENDENCY-RANGE A procedure that takes a and returns that
+decency's range as a string
+ GUIX-NAME A procedure that take a NAME and returns the Guix version of it
+ MAKE-SEXP A procedure that takes , and a list of pairs
+containing (EXPORT-NAME ), returning the package expression as an
+s-expression"
+ (define-record-type
+ (make-node-dependency dependency version exists?)
+ node-dependency?
+ (dependency node-dependency-dependency)
+ (version node-dependency-version)
+ (exists? node-dependency-exists?))
+
+ (define-record-type
+ (make-node name version metadata package dependencies)
+ node?
+ (name node-name)
+ (version node-version)
+ (metadata node-metadata)
+ (package node-package)
+ (dependencies node-dependencies))
+
+ (define mem-name->metadata (memoize name->metadata))
+ (define mem-package-dependencies (memoize package-dependencies))
+
+ (define (semver-range-contains-string? range version)
+ (semver-range-contains? range (string->semver version)))
+
+ (define (name+version name version)
+ (string-append name "-" version))
+
+ (define (public-name name version)
+ "Given a NAME and a VERSION of a package, returns the name of the
+symbol used is define-public"
+ (guix-name (name+version name version)))
+
+ ;; searches searches for a package in guix
+ (define (find-locally name range)
+ (match (find
+ (lambda (package)
+ (semver-range-contains-string?
+ range
+ (package-version package)))
+ (find-packages-by-name (guix-name name)))
+ (#f #f)
+ (package (list (package-version package) #t))))
+
+ ;; searches for a package in some external repo
+ (define (find-remote name range)
+ (let* ((versions (sort
+ (metadata-versions
+ (mem-name->metadata name))
+ version>?))
+ (version (find
+ (lambda (ver)
+ (semver-range-contains-string? range ver))
+ versions)))
+ (list version #f)))
+
+ (define (find-by-name-range name range)
+ "Given a NAME, RANGE this will return a VERSION and BOOL which repesents
+whether the package has been encountered or not."
+ (let ((semver-range (string->semver-range range)))
+ (apply values
+ (or (find-locally name semver-range)
+ (find-remote name semver-range)))))
+
+ (define (make-package-definition node)
+ (let* ((metadata (node-metadata node))
+ (package (node-package node))
+ (dependencies ;; a list of (public-name dependency)
+ (map (lambda (node-dep)
+ (let* ((dep (node-dependency-dependency node-dep))
+ (ver (node-dependency-version node-dep))
+ (name (dependency-name dep)))
+ (list (public-name name ver) dep)))
+ (node-dependencies node)))
+ (sexp (make-sexp metadata package dependencies)))
+ (package->definition sexp #t)))
+
+ (define (dependency->node-dependency dep)
+ (let* ((name (dependency-name dep))
+ (range (dependency-range dep))
+ (version exists? (find-by-name-range name range)))
+ (make-node-dependency dep version exists?)))
+
+ (define (name-version->node name version)
+ (let* ((metadata (mem-name->metadata name))
+ (package (metadata->package metadata version))
+ (dependencies (mem-package-dependencies package))
+ (node-dependencies (map (lambda (dep)
+ (dependency->node-dependency dep))
+ dependencies)))
+ (make-node name version metadata package node-dependencies)))
+
+ (define (node-dependency->node node-dependency)
+ (let* ((dependency (node-dependency-dependency node-dependency))
+ (name (dependency-name dependency))
+ (version (node-dependency-version node-dependency)))
+ (name-version->node name version)))
+
+ (let ((version exists? (find-by-name-range name range)))
+ (if exists?
+ (display
+ (string-append "package " (name+version name version) " alread exists - ")
+ (current-error-port))
+ (map make-package-definition
+ (topological-sort (list (name-version->node name version))
+ (lambda (node)
+ (map (lambda (dep)
+ (node-dependency->node dep))
+ (remove node-dependency-exists?
+ (node-dependencies node))))
+ (lambda (node)
+ (name+version
+ (node-name node)
+ (node-version node))))))))
--
2.24.0