diff options
Diffstat (limited to 'pypi/dependency-solver.scm')
| -rw-r--r-- | pypi/dependency-solver.scm | 475 |
1 files changed, 475 insertions, 0 deletions
diff --git a/pypi/dependency-solver.scm b/pypi/dependency-solver.scm new file mode 100644 index 0000000..b4aa1f2 --- /dev/null +++ b/pypi/dependency-solver.scm @@ -0,0 +1,475 @@ +(define-module (pypi dependency-solver) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 hash-table) + #: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 build-configuration-graph) + #:use-module (pypi package) + #:export (generate-solver-hash-tables + solve-build-configuration-graph + get-scoped-releases-to-versions + + release + release? + release-name + release-version + + root-scope + + scope + scope? + scope-release + scope-parent + + scoped-release + scoped-release? + scoped-release-release + scoped-release-scope + + scoped-requirement + scoped-requirement? + scopred-requirement-requirement + scopred-requirement-scope)) + +(define root-scope '()) + +(define-record-type <release> + (release name version) + release? + (name release-name) + (version release-version)) + +(define (release->string r) + (string-join + (list + (normalise-requirement-name (release-name r)) + "@" + (release-version r)) + "")) + +(define-record-type <scope> + (scope release parent) + scope? + (release scope-release) + (parent scope-parent)) + +(define (scope->string s) + (if (null? s) + "" + (string-join + (list + "(" + (release->string (scope-release s)) + (if (null? (scope-parent s)) + "" + (string-join + (list + " -> " + (scope->string + (scope-parent s))) + "")) + ")") + ""))) + +(define (scope-tree-contains-release? r s) + (if (null? s) + #f + (or + (equal? + (scope-release s) + r) + (scope-tree-contains-release? + r + (scope-parent s))))) + +(define-record-type <scoped-release> + (scoped-release release scope) + scoped-release? + (release scoped-release-release) + (scope scoped-release-scope)) + +(define-record-type <scoped-build-configuration> + (scoped-release release scope) + scoped-release? + (release scoped-release-release) + (scope scoped-release-scope)) + +(define (scoped-release->string sr) + (string-join + (list + (release->string + (scoped-release-release sr)) + (if (null? (scoped-release-scope sr)) + "" + (string-join + (list + " " + (scope->string + (scoped-release-scope sr))) + ""))) + "")) + +(define-record-type <scoped-requirement> + (scoped-requirement requirement scope) + scoped-requirement? + (requirement scoped-requirement-requirement) + (scope scoped-requirement-scope)) + +(define (scoped-requirement->solver-package-name sr) + (string-append + (normalise-requirement-name + (requirement-name + (scoped-requirement-requirement sr))) + (if (null? (scoped-requirement-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-requirement-scope sr)))))) + +(define (scoped-release->solver-package-name sr) + (string-append + (normalise-requirement-name + (release-name (scoped-release-release sr))) + (if (null? (scoped-release-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-release-scope sr)))))) + +(define (scoped-build-configuration->solver-name sr) + (string-append + (normalise-requirement-name + (release-name (scoped-release-release sr))) + (if (null? (scoped-release-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-release-scope sr)))))) + +(define (scoped-requirement->solver-output-string sr) + (string-append + (normalise-requirement-name + (requirement-name + (scoped-requirement-requirement sr))) + (if (null? (scoped-requirement-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-requirement-scope sr)))))) + +(define (scoped-requirement->string sr) + (string-append + (requirement->string + (scoped-requirement-requirement sr)) + (if (null? (scoped-requirement-scope sr)) + "" + (string-append + " " + (scope->string + (scoped-requirement-scope sr)))))) + +(define (build-configuration->release build-configuration) + (let* + ((sdist + (build-configuration-sdist build-configuration)) + (info (sdist-info sdist))) + (release + (pkg-info-name info) + (pkg-info-version info)))) + +(define (process-build-configuration! + build-configuration-graph + scoped-releases-to-scoped-requirements + result-string-to-requirement-options + current-scope build-configuration) + (let* + ((requirement-options-list + (hash-ref + (build-configuration-graph-edges build-configuration-graph) + build-configuration)) + (build-configuration-release + (build-configuration->release build-configuration)) + (build-configuration-scoped-release + (scoped-release + build-configuration-release + current-scope)) + (inner-scope + (scope + build-configuration-release + current-scope)) + (requirement-options-and-scopes + (map + (lambda (requirement-options) + (let* + ((type + (requirement-options-type requirement-options)) + (scope-for-requirement-options + (cond + ((member type '(() install)) + current-scope) + ((member type '(test build)) + inner-scope) + (else + (error "Unrecognised requirement type " type))))) + (cons requirement-options scope-for-requirement-options))) + requirement-options-list)) + (scoped-requirements + (map + (match-lambda + ((requirement-options . scope) + (let + ((sr + (scoped-requirement + (requirement-options-requirement + requirement-options) + scope))) + (hash-set! + result-string-to-requirement-options + (scoped-requirement->solver-output-string sr) + (cons + requirement-options + (or + (hash-ref + result-string-to-requirement-options + (scoped-requirement->solver-output-string sr)) + '()))) + sr))) + requirement-options-and-scopes))) + (if (hash-ref + scoped-releases-to-scoped-requirements + build-configuration-scoped-release) + (begin + (log-msg 'DEBUG "Duplicate scoped-release " build-configuration-scoped-release) + (log-msg 'DEBUG "existing: " (hash-ref scoped-releases-to-scoped-requirements build-configuration-scoped-release)) + (log-msg 'DEBUG "new: " scoped-requirements) + ;(error "Duplicate scoped-release") TODO: Check this + )) + (if (not (hash-ref scoped-releases-to-scoped-requirements + build-configuration-scoped-release)) + (hash-set! + scoped-releases-to-scoped-requirements + build-configuration-scoped-release + scoped-requirements)) + (for-each + (match-lambda + ((requirement-options . scope) + (for-each + (lambda (build-configuration) + (process-build-configuration! + build-configuration-graph + scoped-releases-to-scoped-requirements + result-string-to-requirement-options + scope + build-configuration)) + (requirement-options-options requirement-options)))) + requirement-options-and-scopes))) + +(define (generate-solver-hash-tables + build-configuration-graph) + (let + ((scoped-releases-to-scoped-requirements (make-hash-table)) + (result-string-to-requirement-options (make-hash-table))) + (for-each + (lambda (requirement-options) + (let + ((solver-name + (normalise-requirement-name + (requirement-name (requirement-options-requirement requirement-options))))) + (hash-set! + result-string-to-requirement-options + solver-name + (cons + requirement-options + (or + (hash-ref + result-string-to-requirement-options + solver-name) + '()))) + (for-each + (lambda (build-configuration) + (process-build-configuration! + build-configuration-graph + scoped-releases-to-scoped-requirements + result-string-to-requirement-options + root-scope + build-configuration)) + (requirement-options-options requirement-options)))) + (build-configuration-graph-roots build-configuration-graph)) + (log-msg 'DEBUG + "generate-solver-hash-tables result \n" + (string-join + (hash-map->list + (lambda (k v) + (string-join + (cons + (scoped-release->string k) + (map + (lambda (sr) + (string-append + " " + (scoped-requirement->string sr) + "\n")) + v)) + "\n")) + scoped-releases-to-scoped-requirements)) + "\n") + (values + scoped-releases-to-scoped-requirements + result-string-to-requirement-options))) + +(define (scoped-releases-to-scoped-requirements->string-to-scoped-releases + ht) + (hash-map->list + (lambda (scoped-release scoped-requirements) + (cons + (scoped-release->solver-package-name scoped-release) + scoped-release)) + ht)) + +(define (solve-build-configuration-graph + build-configuration-graph) + (receive (scoped-releases-to-scoped-requirements + result-string-to-requirement-options) + (generate-solver-hash-tables + build-configuration-graph) + (let* + ((requirements + (map + (lambda (requirement-options) + (requirement-options-requirement requirement-options)) + (build-configuration-graph-roots build-configuration-graph))) + (result + (get-versions-or-error + (hash-map->list + (lambda (scoped-release scoped-requirements) + (list + (scoped-release->solver-package-name scoped-release) + (release-version + (scoped-release-release scoped-release)) + (map + (lambda (sr) + (list + (scoped-requirement->solver-package-name sr) + (filter + (lambda (s) + (not (equal? s ""))) + (string-split + (requirement-specifiers + (scoped-requirement-requirement sr)) + #\,)))) + scoped-requirements))) + scoped-releases-to-scoped-requirements) + (concatenate + (map + (lambda (r) + (map + (lambda (s) + (string-append + (normalise-requirement-name (requirement-name r)) + s)) + (string-split + (requirement-specifiers r) + #\,))) + requirements))))) + (if (string? result) + (begin + (log-msg 'ERROR "Error during dependency resolution") + (hash-for-each + (lambda (s-release s-requirements) + (log-msg 'ERROR + (scoped-release->string s-release) ":") + (for-each + (lambda (s-requirement) + (log-msg 'ERROR " " (scoped-requirement->string s-requirement))) + s-requirements)) + scoped-releases-to-scoped-requirements) + (log-msg 'ERROR "Requirements:") + (for-each + (lambda (r) + (log-msg 'ERROR " " (requirement->string r))) + requirements) + (error result)) + (alist->hash-table + (concatenate + (map + (match-lambda + ((result-string version) + (log-msg 'DEBUG result-string " - " version) + (map + (lambda (requirement-options) + (cons requirement-options version)) + (or + (hash-ref + result-string-to-requirement-options + result-string) + (begin + (log-msg 'ERROR "|" result-string "| not found") + #f))))) + result))))))) + +(define (select-build-configuration-from-requirement-options + requirement-options + version) + (find + (lambda (build-configuration) + (equal? + version + (pkg-info-version + (sdist-info + (build-configuration-sdist build-configuration))))) + (requirement-options-options requirement-options))) + +(define (filter-build-configuration-graph + graph + requirement-options-to-version) + (build-configuration-graph + (map + (lambda (requirement-options) + (select-build-configuration-from-requirement-options + requirement-options + (hash-ref + requirement-options-to-version + requirement-options))) + (build-configuration-graph-roots graph)) + (alist->hash-table + (hash-map->list + (lambda (build-configuration requirement-options-list) + (cons + build-configuration + (map + (lambda (requirement-options) + (select-build-configuration-from-requirement-options + requirement-options + (hash-ref + requirement-options-to-version + requirement-options))) + requirement-options-list))) + (build-configuration-graph-edges graph))))) + +(define %solver-location "") + +(define (get-versions-or-error name-version-requirements overall-requirements) + (log-msg 'DEBUG "get-versions-or-error\n") + (if (not (string-null? %solver-location)) + (python-eval (string-append "import sys; sys.path.append(\"" %solver-location "\");"))) + (python-eval "from solver import get_versions_or_error") + (log-msg 'DEBUG "name-version-requirements\n") + (log-msg 'DEBUG name-version-requirements) + (log-msg 'DEBUG "\n") + (log-msg 'DEBUG "overall-requirements\n") + (log-msg 'DEBUG overall-requirements) + (log-msg 'DEBUG "\n") + (python-apply + '(solver get_versions_or_error) + (list name-version-requirements overall-requirements) + '())) |