1 files changed, 331 insertions, 0 deletions
diff --git a/pypi/build-configuration-graph.scm b/pypi/build-configuration-graph.scm
new file mode 100644
index 0000000..02fc5cf
--- /dev/null
+++ b/pypi/build-configuration-graph.scm
@@ -0,0 +1,331 @@
+(define-module (pypi build-configuration-graph)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (logging logger)
+  #:use-module (pyguile)
+  #:use-module (pypi requirement)
+  #:use-module (pypi sdist)
+  #:use-module (pypi sdist-store)
+  #:use-module (pypi package)
+  #:export (build-configuration-graph
+            build-configuration-graph?
+            build-configuration-graph-roots
+            build-configuration-graph-edges
+
+            build-configuration
+            build-configuration?
+            build-configuration-sdist
+            build-configuration-extras
+            build-configuration-tests?
+            build-configuration-omitted-dependencies
+
+            requirement-options
+            requirement-options?
+            requirement-options-type
+            requirement-options-requirement
+            requirement-options-options
+
+            log-build-configuration-graph
+
+            requirements->build-configuration-graph
+
+            dependency-loop-can-be-broken-by-not-running-tests?))
+
+(define-record-type <build-configuration-graph>
+  (build-configuration-graph
+    roots
+    edges)
+  build-configuration-graph?
+  (roots build-configuration-graph-roots)
+  (edges build-configuration-graph-edges))
+
+(define-record-type <requirement-options>
+  (requirement-options
+    type
+    requirement
+    options)
+  requirement-options?
+  (type requirement-options-type)
+  (requirement requirement-options-requirement)
+  (options requirement-options-options))
+
+(define-record-type <build-configuration>
+  (build-configuration
+    sdist
+    extras
+    tests?
+    omitted-dependencies)
+  build-configuration?
+  (sdist build-configuration-sdist)
+  (extras build-configuration-extras)
+  (tests? build-configuration-tests?)
+  (omitted-dependencies build-configuration-omitted-dependencies))
+
+(define (requirements->build-configuration-graph
+          sdist-store
+          requirements)
+  (let
+    ((edges (make-hash-table))
+     (roots
+       (map
+         (lambda (requirement)
+           (requirement-options
+             '() ; No type
+             requirement
+             (get-build-configurations-for-requirement
+               sdist-store
+               '() ; No dependant build configurations
+               requirement
+               #t
+               '())))
+         requirements)))
+    (for-each
+      (lambda (requirement-options)
+        (for-each
+          (lambda (build-configuration)
+            (add-build-configuration-closure-to-graph!
+              sdist-store
+              build-configuration
+              '()
+              edges))
+          (requirement-options-options requirement-options)))
+      roots)
+    (build-configuration-graph roots edges)))
+
+(define (requirement-options-for-sdist-requirements
+          sdist
+          sdist-store
+          run-tests
+          omitted-dependencies
+          dependant-build-configurations)
+  (concatenate
+    (map
+      (lambda (type requirements)
+        (map
+          (lambda (requirement)
+            (requirement-options
+              type
+              requirement
+              (get-build-configurations-for-requirement
+                sdist-store
+                dependant-build-configurations
+                requirement
+                run-tests
+                '())))
+          (filter
+            (lambda (requirement)
+              (log-msg 'DEBUG "filtering requirements")
+              (log-msg 'DEBUG requirement)
+              (log-msg 'DEBUG omitted-dependencies)
+              (not (member (requirement-name requirement)
+                           omitted-dependencies)))
+            requirements)))
+      '(build test install)
+      (list
+        (sdist-build-requires sdist)
+        (if run-tests
+          (sdist-tests-require sdist)
+          '())
+        (sdist-install-requires sdist)))))
+
+(define (log-build-configuration-graph level graph)
+  (letrec
+    ((log-msg'
+       (lambda (msg . parts)
+         (if (null? level)
+           (begin
+             (for-each display (cons msg parts))
+             (display "\n"))
+           (apply log-msg (cons level (cons msg parts))))))
+     (log-requirement-options
+       (lambda (indent requirement-options)
+         (if (> indent 50)
+           (error "graph too deep"))
+         (log-msg'
+                  (make-string (* 4 indent) #\space)
+                  (requirement-name
+                    (requirement-options-requirement
+                      requirement-options)))
+         (for-each
+           (lambda (build-configuration)
+             (log-msg'
+                      (make-string (+ 2 (* 4 indent)) #\space)
+                      (sdist-short-description
+                        (build-configuration-sdist build-configuration))
+                      " (tests? " (build-configuration-tests? build-configuration) ")")
+             (for-each
+               (lambda (requirement-options)
+                 (log-requirement-options
+                   (+ 1 indent)
+                   requirement-options))
+               (hash-ref
+                 (build-configuration-graph-edges graph)
+                 build-configuration)))
+           (requirement-options-options requirement-options)))))
+    (for-each
+      (lambda (requirement-options)
+        (log-requirement-options 0 requirement-options))
+      (build-configuration-graph-roots graph))
+    graph))
+
+(define (sdist->build-configuration
+          sdist
+          dependant-build-configurations
+          extras
+          run-tests
+          omitted-dependencies)
+  (let
+    ((initial-build-configuration
+       (build-configuration
+         sdist
+         extras
+         run-tests
+         omitted-dependencies)))
+    (if (not (member
+               initial-build-configuration
+               dependant-build-configurations))
+      initial-build-configuration
+      (if
+        (and
+          run-tests
+          (dependency-loop-can-be-broken-by-not-running-tests?
+            (reverse
+              (cons
+                initial-build-configuration
+                dependant-build-configurations))))
+        (sdist->build-configuration
+          sdist
+          dependant-build-configurations
+          extras
+          #f
+          omitted-dependencies)
+        (let*
+          ((build-configuration-to-omit
+             (first dependant-build-configurations))
+           (sdist-name
+              (pkg-info-name
+                (sdist-info
+                  (build-configuration-sdist build-configuration-to-omit)))))
+          (if (not (member
+                     sdist-name
+                     omitted-dependencies))
+            (sdist->build-configuration
+              sdist
+              dependant-build-configurations
+              extras
+              #f
+              (cons
+                sdist-name
+                omitted-dependencies))
+            (begin
+              (log-dependency-loop dependant-build-configurations)
+              (error "Cannot solve build dependency issue"))))))))
+
+(define (log-dependency-loop
+          dependant-build-configurations)
+  (log-msg 'ERROR "Dependency loop:\n")
+  (for-each
+    (lambda (build-configuration)
+      (log-msg 'ERROR build-configuration "\n"))
+    (reverse dependant-build-configurations)))
+
+(define (add-build-configuration-closure-to-graph!
+          sdist-store
+          build-configuration
+          dependant-build-configurations
+          graph)
+  (if (not (hash-ref
+             graph
+             build-configuration))
+    (let*
+      ((new-dependant-build-configurations
+          (cons build-configuration
+                dependant-build-configurations))
+       (requirement-options-for-sdist
+         (requirement-options-for-sdist-requirements
+           (build-configuration-sdist build-configuration)
+           sdist-store
+           (build-configuration-tests? build-configuration)
+           (build-configuration-omitted-dependencies build-configuration)
+           new-dependant-build-configurations)))
+      (hash-set!
+        graph
+        build-configuration
+        requirement-options-for-sdist)
+      (for-each
+        (lambda (requirement-options)
+          (for-each
+            (lambda (build-configuration)
+              (add-build-configuration-closure-to-graph!
+                sdist-store
+                build-configuration
+                new-dependant-build-configurations
+                graph))
+            (requirement-options-options
+              requirement-options)))
+        requirement-options-for-sdist))))
+
+(define (dependency-loop-can-be-broken-by-not-running-tests?
+          dependant-build-configurations)
+  (let*
+    ((a (first dependant-build-configurations)))
+    (if (null? a)
+      #f
+      (let
+        ((b (if (null? (cdr dependant-build-configurations))
+              '()
+              (second dependant-build-configurations))))
+        (if (null? b)
+          #f
+          (or
+            (sdist-has-test-requirement-matching-normalised-requirement-name
+              a
+              (normalise-requirement-name
+               (pkg-info-name
+                 (sdist-info
+                   (build-configuration-sdist
+                     b)))))
+            (dependency-loop-can-be-broken-by-not-running-tests?
+              (cdr dependant-build-configurations))))))))
+
+(define (sdist-has-test-requirement-matching-normalised-requirement-name
+          sdist
+          normalised-requirement-name)
+  (any
+    (lambda (test-requirement)
+      (equal? normalised-requirement-name
+              (normalise-requirement-name
+                (requirement-name
+                  test-requirement))))
+    (sdist-tests-require
+      (build-configuration-sdist
+        sdist))))
+
+(define (get-build-configurations-for-requirement
+          sdist-store
+          dependant-build-configurations
+          requirement
+          run-tests
+          omitted-dependencies)
+  (let
+    ((sdists
+      (get-sdists-by-version-meeting-requirement
+        sdist-store
+        requirement)))
+    (if (null? sdists)
+      (throw
+        unsatisfied-requirements-error
+        (list requirement))
+      (map
+        (match-lambda
+          ((version . sdist)
+           (sdist->build-configuration
+             sdist
+             dependant-build-configurations
+             (requirement-extras requirement)
+             (and
+               run-tests
+               (requirement-run-tests requirement))
+             omitted-dependencies)))
+        sdists))))