[bug#38408] [PATCH 2/3] gnu: added new procedure, recusive-import-semver

[Martin Becze]

* gnu/packages.scm (recusive-import-semver): New Procedure
* gnu/packages.scm (package->definition)[arguments]: New argument, "latest"
* tests/import-utils.scm: tests for recusive-import-semver
---
 guix/import/utils.scm  | 181 +++++++++++++++++++++++++++++++++++++++--
 tests/import-utils.scm | 162 ++++++++++++++++++++++++++++++++++++
 2 files changed, 336 insertions(+), 7 deletions(-)

diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 4694b6e7ef..6932614f8e 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2017, 2019 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2018 Oleg Pykhalov <address@hidden>
 ;;; Copyright © 2019 Robert Vollmert <address@hidden>
+;;; Copyright © 2019 Martin Becze <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@
   #:use-module (guix discovery)
   #:use-module (guix build-system)
   #:use-module (guix gexp)
+  #:use-module (guix memoization)
   #:use-module (guix store)
   #:use-module (guix download)
   #:use-module (gnu packages)
@@ -43,6 +45,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-41)
+  #:use-module (semver)
+  #:use-module (semver ranges)
   #:export (factorize-uri
 
             flatten
@@ -69,7 +73,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
@@ -257,13 +262,15 @@ package definition."
     ((package-inputs ...)
      `((native-inputs (,'quasiquote ,package-inputs))))))
 
-(define (package->definition guix-package)
+(define* (package->definition guix-package #:optional (latest #t))
   (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 latest
+                                          name
+                                          (string-append name "-" version)))
         ,guix-package))))
 
 (define (build-system-modules)
@@ -414,3 +421,163 @@ dependencies."
     step
     ;; initial state
     (step initial-state)))
+
+(define* (recursive-import-semver #:key name
+                                  (version #f)
+                                  name->metadata
+                                  metadata->package
+                                  metadata-versions
+                                  package-dependencies
+                                  dependency-name
+                                  dependency-range
+                                  guix-name
+                                  make-sexp)
+  "Generates a stream of package expressions for the dependencies of the given 
+NAME and VERSION. The dependencies will be resolved using semantic versioning.
+This procedure makes the assumption that most package repositories will, for a
+given package provide some <metadata> 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
+  VERSION - The version of the package to import
+  NAME->METADATA - A procedure that takes a NAME of a package and returns that
+package's <metadata>
+  METADATA->PACKAGE A procedure that takes a package's <metadata> and VERSION 
+and returns the <package> for the given VERSION
+  METADATA-VERSIONS A procedure that that takes a packages <metadata> and
+returns a list of version as strings that are available for the given package
+  PACKAGE-DEPENDENCIES a procedure that returns a list of <dependency> given a 
+<package>
+  DEPENDENCY-NAME A procedure that takes a <dependency> and returns the its 
name
+  DEPENDENCY-RANGE A procedure that takes a <dependency> 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 <metadata>, <package> and a list of pairs
+containing (EXPORT-NAME <dependency>), returning the package expression as an 
+s-expression"
+  (define mem-name->metadata (memoize name->metadata))
+
+  (define (latest? versions version)
+    (equal? (car versions) version))
+
+  (define (sorted-versions metadata)
+    (sort (metadata-versions metadata) version>?))
+
+  (define (name->versions name)
+    (sorted-versions (mem-name->metadata name)))
+
+  (define (semver-range-contains-string? range version)
+    (semver-range-contains? range
+                            (string->semver version)))
+
+  (define (guix-export-name name version)
+    (let ((versions (name->versions name))
+          (name (guix-name name)))
+      (if (latest? versions version)
+          name
+          (string-append name "-" version))))
+
+  ;; checks to see if we already defined or want to define a dep
+  (define (find-known name range known)
+    (match
+        (find
+         (match-lambda ((dep-name version)
+                        (and
+                         (string=? dep-name name)
+                         (semver-range-contains-string? range version))))
+         known)
+
+      (#f #f)
+      ((name version) (list (guix-export-name name version) version #f)))
+    )
+
+  ;; searches searches for a package in guix
+  (define (find-locally name range)
+    (match
+        (find
+         (match-lambda ((_ _ package)
+                        (semver-range-contains-string?
+                         range
+                         (package-version package))))
+         (find-packages-by-name*/direct (guix-name name)))
+      (#f #f)
+      ((_ export-symbol package) (list
+                                  (symbol->string export-symbol)
+                                  (package-version package) #f))))
+
+  ;; searches for a package in some external repo
+  (define (find-remote name range)
+    (let* ((versions (name->versions name))
+           (version (find
+                     (lambda (ver)
+                       (semver-range-contains-string? range ver))
+                     versions))
+           (export-name (guix-export-name name version)))
+      `(,export-name ,version #t)))
+
+
+  (define (find-dep-version dep known-deps)
+    (let* ((name (dependency-name dep))
+           (range (string->semver-range (dependency-range dep)))
+           (export-name-version-needed
+            (or (find-known name range known-deps)
+                (find-locally name range)
+                (find-remote name range))))
+      `(,name ,@export-name-version-needed ,dep)
+      ))
+
+  (define (make-package-definition name version known-deps)
+    (let* ((metadata (mem-name->metadata name))
+           (versions (sorted-versions metadata))
+           (package (metadata->package metadata version))
+           (deps (map (lambda (dep)
+                        (find-dep-version dep known-deps))
+                      (package-dependencies package)))
+           (sexp
+            (make-sexp metadata package
+                       (map
+                        (match-lambda ((_ export-symbol _ _ dep)
+                                       (list export-symbol dep)))
+                        deps))))
+      (values
+       (package->definition sexp (latest? versions version))
+       (filter-map
+        (match-lambda ((name _ version need? dep)
+                       (if need?
+                           (list name version)
+                           #f)))
+        deps))))
+
+  (define initial-state
+    (list #f
+          (list
+           ;; packages to find
+           (list name (if version
+                          version
+                          (car (name->versions name)))))
+          ;; packages that have been found
+          (list)))
+
+  (define (step state)
+    (match state
+      ((prev ((next-name next-version) . rest) done)
+       (receive (package dependencies)
+           (make-package-definition next-name next-version
+                                    (append done rest `((,next-name 
,next-version))))
+         (list
+          package
+          (append rest dependencies)
+          (cons (list next-name next-version) done))))
+      ((prev '() done)
+       (list #f '() done))))
+ 
+  (stream-unfold
+   ;; map: produce a stream element
+   (match-lambda ((latest queue done) latest))
+   ;; predicate
+   (match-lambda ((latest queue done) latest))
+   step
+   (step initial-state)))
diff --git a/tests/import-utils.scm b/tests/import-utils.scm
index c3ab25d788..4ed3a5e1da 100644
--- a/tests/import-utils.scm
+++ b/tests/import-utils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2016 Ben Woodcroft <address@hidden>
+;;; Copyright © 2016 Martin Becze <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,10 @@
   #:use-module (guix packages)
   #:use-module (guix build-system)
   #:use-module (gnu packages)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-41)
   #:use-module (srfi srfi-64))
 
 (test-begin "import-utils")
@@ -120,4 +125,161 @@
                  ("license" . #f))))
     (package-native-inputs (alist->package meta))))
 
+(define-record-type <metadata>
+  (make-metadata name versions)
+  metadata?
+  (name metadata-name)
+  (versions  metadata-versions))
+
+(define-record-type <package>
+  (make-package version dependencies)
+  package?
+  (version package-version)
+  (dependencies package-dependencies))
+
+(define-record-type <dependency>
+  (make-dependency name range)
+  dependency?
+  (name dependency-name)
+  (range dependency-range))
+
+(define (metadata-semver-versions metadata)
+  (map (lambda (p)
+         (package-version p))
+       (metadata-versions metadata)))
+
+(define (metadata->package metadata version)
+  (find
+   (lambda (package)
+     (equal? (package-version package) version))
+   (metadata-versions metadata)))
+
+(define (make-sexp metadata package dependencies)
+  `(package
+    (name ,(guix-name (metadata-name metadata)))
+    (version ,(package-version package))
+    (dependcies ,(map
+                  (match-lambda ((public-name dep)
+                                 (list (guix-name (dependency-name dep)) 
public-name)))
+                  dependencies))))
+
+(define (guix-name name)
+  (string-append "test-" name))
+
+(define packages
+  `(("no-deps" . (("1.0.0" . ()) ("0.1.0" . ())))
+    ("one-dep" . (("1.0.0" . (("no-deps" "^1.0")))
+                  ("0.1.0" . (("no-deps" "^0.1.0")))))
+    ("shared-dep" . (("1.0.0" . (("one-dep" "^0.1.0")
+                                 ("no-deps" "*")))))
+    ("recursive" . (("1.0.0" . (("recursive" "=1.0.0")))))
+    ("already-packaged" . (("1.0.0" . (("rust" "~1.28")))))))
+
+(define (name->metadata name)
+  (let ((versions (assoc-ref packages name)))
+    (make-metadata name
+                   (map
+                    (match-lambda
+                      ((version . deps)
+                       (make-package version
+                                     (map
+                                      (lambda (name-range)
+                                        (apply make-dependency name-range))
+                                      deps))))
+                    versions))))
+
+(define* (test-recursive-importer name version #:optional (guix-name 
guix-name))
+  (recursive-import-semver #:name name
+                           #:version version
+                           #:name->metadata name->metadata
+                           #:metadata->package metadata->package
+                           #:metadata-versions metadata-semver-versions
+                           #:package-dependencies package-dependencies
+                           #:dependency-name dependency-name
+                           #:dependency-range dependency-range
+                           #:guix-name guix-name
+                           #:make-sexp make-sexp))
+
+(test-equal "recursive import test with no dependencies"
+  `((define-public test-no-deps
+      (package
+        (name "test-no-deps")
+        (version "1.0.0")
+        (dependcies ()))))
+  (stream->list (test-recursive-importer "no-deps" "1.0.0")))
+
+(test-equal "recursive import test with one dependencies"
+  `((define-public test-one-dep
+      (package
+        (name "test-one-dep")
+        (version "1.0.0")
+        (dependcies (("test-no-deps" "test-no-deps")))))
+    (define-public test-no-deps
+      (package
+        (name "test-no-deps")
+        (version "1.0.0")
+        (dependcies ()))))
+  (stream->list (test-recursive-importer "one-dep" "1.0.0")))
+
+(test-equal "recursive import test with recursuve dependencies"
+  `((define-public test-recursive
+      (package
+        (name "test-recursive")
+        (version "1.0.0")
+        (dependcies (("test-recursive" "test-recursive"))))))
+  (stream->list (test-recursive-importer "recursive" "1.0.0")))
+
+(test-equal "recursive import test with no dependencies using an old version"
+  `((define-public test-no-deps-0.1.0
+      (package
+        (name "test-no-deps")
+        (version "0.1.0")
+        (dependcies ()))))
+  (stream->list (test-recursive-importer "no-deps" "0.1.0")))
+
+(test-equal "recursive import test with one dependencies unsing an old version"
+  `((define-public test-one-dep-0.1.0
+      (package
+        (name "test-one-dep")
+        (version "0.1.0")
+        (dependcies (("test-no-deps" "test-no-deps-0.1.0")))))
+    (define-public test-no-deps-0.1.0
+      (package
+        (name "test-no-deps")
+        (version "0.1.0")
+        (dependcies ()))))
+  (stream->list (test-recursive-importer "one-dep" "0.1.0")))
+
+(test-equal "recursive import test with with dependency that is already in the 
repo"
+  `((define-public test-already-packaged
+      (package (name "test-already-packaged")
+               (version "1.0.0")
+               (dependcies
+                (("test-rust" "rust-1.28"))))))
+  (stream->list (test-recursive-importer "already-packaged" "1.0.0" identity)))
+
+(test-equal "shared dependencies"
+  `((define-public test-shared-dep
+      (package
+        (name "test-shared-dep")
+        (version "1.0.0")
+        (dependcies (("test-one-dep" "test-one-dep-0.1.0")
+                     ("test-no-deps" "test-no-deps")))))
+    (define-public test-one-dep-0.1.0
+      (package
+        (name "test-one-dep")
+        (version "0.1.0")
+        (dependcies (("test-no-deps" "test-no-deps-0.1.0")))))
+    (define-public test-no-deps
+      (package
+        (name "test-no-deps")
+        (version "1.0.0")
+        (dependcies ())))
+    (define-public test-no-deps-0.1.0
+      (package
+        (name "test-no-deps")
+        (version "0.1.0")
+        (dependcies()))))
+  (stream->list (test-recursive-importer "shared-dep" "1.0.0")))
+
 (test-end "import-utils")
-- 
2.24.0