1 files changed, 190 insertions, 0 deletions
diff --git a/pypi/sdist-store.scm b/pypi/sdist-store.scm
new file mode 100644
index 0000000..f1e0277
--- /dev/null
+++ b/pypi/sdist-store.scm
@@ -0,0 +1,190 @@
+(define-module (pypi sdist-store)
+  #:use-module (logging logger)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (guix ui)
+  #:use-module (guix packages)
+  #:use-module (guix build utils)
+  #:use-module (guix download)
+  #:use-module (pypi sdist)
+  #:use-module (pypi version)
+  #:use-module (pypi requirement)
+  #:export (make-sdist-store
+            add-sdist
+            add-sdists
+            get-sdist
+            get-sdists
+            get-sdist-list
+            get-sdists-by-version-meeting-requirement
+            get-sdist-best-matching-requirement
+            get-sdist-best-matching-requirements
+            store-can-satisfy-requirement?
+            log-sdist-store
+            create-sdists-module))
+
+(define (vhash-set key value vhash)
+  (vhash-cons
+    key
+    value
+    (vhash-delete
+      key
+      vhash)))
+
+(define (make-sdist-store)
+  vlist-null)
+
+(define (add-sdist store sd)
+  (let*
+    ((info (sdist-info sd))
+     (name (normalise-requirement-name (pkg-info-name info)))
+     (version (pkg-info-version info))
+     (versions
+       (vhash-assoc
+         (normalise-requirement-name name)
+         store)))
+   (vhash-set
+     name
+     (vhash-set
+       version
+       sd
+       (if versions
+         (cdr versions)
+         vlist-null))
+     store)))
+
+(define (log-sdist-store level sdist-store)
+  (for-each
+    (match-lambda
+      ((name . versions)
+       (log-msg level name ":")
+       (for-each
+         (match-lambda
+           ((version . sdist)
+            (log-msg level "    " version)))
+         (vlist->list versions))))
+    (vlist->list sdist-store)))
+
+(define (add-sdists store sds)
+  (fold
+    (lambda (sd store)
+      (add-sdist store sd))
+    store
+    sds))
+
+(define (get-sdists store name) ; TODO: Change this, as it does not get sdists (instead it gets an alist)
+  (let
+    ((p
+       (vhash-assoc (normalise-requirement-name name) store)))
+    (if p
+      (vlist->list (cdr p))
+      '())))
+
+(define (get-sdists-by-version-meeting-requirement sdist-store requirement)
+  (filter
+    (match-lambda
+      ((version . sd)
+       (sdist-meets-requirement sd requirement)))
+    (get-sdists sdist-store (requirement-name requirement))))
+
+(define (get-sdist store name version)
+  (assoc-ref
+    (get-sdists store name)
+    version))
+
+(define (sort-version-alist al)
+  (let*
+    ((versions (map car al))
+     (sorted-versions (sort-versions versions)))
+    (map
+      (lambda (version)
+        (cons version (assoc-ref al version)))
+      sorted-versions)))
+
+
+(define (get-sdist-list store)
+  (apply
+    append
+    (map
+      cdr
+      (stable-sort
+        (vlist->list
+          (vlist-map
+            (match-lambda
+              ((name . versions)
+               (cons
+                 name
+                 (map cdr
+                    (sort-version-alist
+                      (vlist->list versions))))))
+            store))
+        (lambda (x y)
+          (string<? (car x) (car y)))))))
+
+
+(define (create-sdists-module store module path)
+ (call-with-output-file
+   path
+   (lambda (port)
+     (pretty-print
+       `(define-module ,module
+          #:use-module (srfi srfi-1)
+          #:use-module (srfi srfi-13)
+          #:use-module (guix packages)
+          #:use-module (guix download)
+          #:use-module (guix build utils)
+          #:use-module (pypi sdist)
+          #:use-module (pypi requirement))
+       port)
+     (pretty-print
+       `(define-public
+          sdists
+          ,(append
+             '(list)
+             (map get-quoted-sdist (get-sdist-list store))))
+       port))))
+
+(define (store-can-satisfy-requirement? store r)
+  (get-sdist-best-matching-requirement store r))
+
+(define (get-sdist-best-matching-requirement store r)
+  (get-sdist-best-matching-requirements store (list r)))
+
+(define (get-sdist-best-matching-requirements store requirements)
+  (let*
+    ((unique-names
+       (apply
+         lset-adjoin
+         (append
+           (list equal? '())
+           (map (lambda (r) (normalise-requirement-name
+                                                    (requirement-name r)))
+                                      requirements))))
+     (normalised-name (first unique-names)))
+    (if (not (eq? 1 (length unique-names)))
+      (error "Not all requirements are for the name package"
+           requirements))
+    (let ((sorted-suitable-versions
+            (let*
+              ((sdists (filter
+                         (lambda (sd)
+                           (every
+                             (lambda (r)
+                               (sdist-meets-requirement sd r))
+                             requirements))
+                         (map cdr (get-sdists store normalised-name))))
+               (sdists-and-versions
+                 (map
+                   (lambda (sd) (cons (pkg-info-version (sdist-info sd)) sd))
+                   sdists))
+               (sorted-versions
+                 (sort-versions (map car sdists-and-versions))))
+              (map
+                (lambda (v) (assoc-ref sdists-and-versions v))
+                sorted-versions))))
+      (if (> (length sorted-suitable-versions) 0)
+          (first sorted-suitable-versions)
+          #f))))