1 files changed, 192 insertions, 0 deletions
diff --git a/pypi/sdist.scm b/pypi/sdist.scm
new file mode 100644
index 0000000..e0e5233
--- /dev/null
+++ b/pypi/sdist.scm
@@ -0,0 +1,192 @@
+(define-module (pypi sdist)
+  #:use-module (logging logger)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-13)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (guix ui)
+  #:use-module (guix base32)
+  #:use-module (guix records)
+  #:use-module (guix download)
+  #:use-module (guix packages)
+  #:use-module (pypi requirement)
+  #:use-module (pypi utils)
+  #:export (sdist
+            sdist?
+            sdist-info
+            sdist-build-requires
+            sdist-tests-require
+            sdist-install-requires
+            sdist-extras-require
+            sdist-source
+
+            sdist-short-description
+
+            get-quoted-sdist
+            sdist-meets-requirement
+            add-build-requirements-to-sdist
+            add-test-requirements-to-sdist
+
+            pkg-info
+            pkg-info?
+            pkg-info-name
+            pkg-info-version
+            pkg-info-home-page
+            pkg-info-synopsis
+            pkg-info-description
+            pkg-info-license
+
+            get-quoted-pkg-info
+
+            get-extra-combinations
+            get-requirements-for-extras
+
+            extra
+            extra?
+            extra-name
+            extra-requires))
+
+(define-record-type* <sdist>
+  sdist make-sdist
+  sdist?
+  (info              sdist-info)
+  (build-requires    sdist-build-requires
+                     (default '()))
+  (tests-require     sdist-tests-require
+                     (default '()))
+  (install-requires  sdist-install-requires
+                     (default '()))
+  (extras-require    sdist-extras-require
+                     (default '()))
+  (source            sdist-source))
+
+(define (get-quoted-sdist sdist)
+  `(sdist
+     (info ,(get-quoted-pkg-info (sdist-info sdist)))
+     (build-requires ,(append '(list)
+                              (map get-quoted-requirement
+                                   (sdist-build-requires sdist))))
+     (tests-require ,(append '(list)
+                             (map get-quoted-requirement
+                                  (sdist-tests-require sdist))))
+     (install-requires ,(append '(list)
+                                (map get-quoted-requirement
+                                     (sdist-install-requires sdist))))
+     (extras-require ,(append '(list)
+                              (map
+                                get-quoted-extra
+                                (sdist-extras-require sdist))))
+     (source ,(get-quoted-origin (sdist-source sdist)))))
+
+(define (add-build-requirements-to-sdist sd reqs)
+  (let
+    ((duplicate
+       (any
+         (lambda (r)
+           (member r (sdist-build-requires sd)))
+         reqs)))
+    (if duplicate
+      (error "Cannot add duplicate build requirement " duplicate)))
+  (log-msg 'INFO
+     "Adding build requirements to "
+     (sdist-short-description sd)
+     " " reqs)
+  (sdist
+    (inherit sd)
+    (build-requires
+      (append
+        (sdist-build-requires sd)
+        reqs))))
+
+(define (add-test-requirements-to-sdist sd reqs)
+  (log-msg 'INFO
+     "Adding test requirements to "
+     (sdist-short-description sd)
+     " " reqs)
+  (let
+    ((duplicate
+       (any
+         (lambda (r)
+           (member r (sdist-tests-require sd)))
+         reqs)))
+    (if duplicate
+      (error "Cannot add duplicate test requirement " duplicate)))
+  (sdist
+    (inherit sd)
+    (tests-require
+      (append
+        (sdist-tests-require sd)
+        reqs))))
+
+(define (get-quoted-origin o)
+  `(origin
+     (method ,(let
+                 ((m (origin-method o)))
+                 (cond
+                   ((eqv? url-fetch m)
+                      'url-fetch)
+                   (else
+                     (report-error (_ "unknown method ") m "\n")))))
+     (uri ,(origin-uri o))
+     (sha256
+       (base32
+         ,(bytevector->nix-base32-string (origin-sha256 o))))))
+
+(define-record-type* <pkg-info>
+  pkg-info make-pkg-info
+  pkg-info?
+  (name  pkg-info-name)
+  (version  pkg-info-version)
+  (home-page  pkg-info-home-page)
+  (synopsis  pkg-info-synopsis)
+  (description  pkg-info-description)
+  (license  pkg-info-license))
+
+(define (get-quoted-pkg-info pi)
+  `(pkg-info
+     (name ,(pkg-info-name pi))
+     (version ,(pkg-info-version pi))
+     (home-page ,(pkg-info-home-page pi))
+     (synopsis ,(pkg-info-synopsis pi))
+     (description ,(pkg-info-description pi))
+     (license ,(pkg-info-license pi))))
+
+(define (get-extra-combinations sdist)
+  (all-combinations
+    (sdist-extras-require sdist)))
+
+(define (get-requirements-for-extras sd extras)
+  (apply
+    append
+    (map
+      (lambda (extra)
+        (assoc-ref extra (sdist-extras-require sd)))
+      extras)))
+
+
+(define (sdist-meets-requirement sd r)
+  (version-meets-requirement r
+                             (pkg-info-version (sdist-info sd))))
+
+(define-record-type <extra>
+  (extra name requirements)
+  extra?
+  (name extra-name)
+  (requirements extra-requires))
+
+(define (get-quoted-extra e)
+  `(extra
+     ,(extra-name e)
+     ,(append '(list)
+        (map get-quoted-requirement
+        (extra-requires e)))))
+
+(define (sdist-short-description sd)
+  (let
+    ((info (sdist-info sd)))
+    (string-append
+      (pkg-info-name info)
+      "@"
+      (pkg-info-version info))))