diff options
Diffstat (limited to 'pypi/package.scm')
| -rw-r--r-- | pypi/package.scm | 524 |
1 files changed, 524 insertions, 0 deletions
diff --git a/pypi/package.scm b/pypi/package.scm new file mode 100644 index 0000000..8cae990 --- /dev/null +++ b/pypi/package.scm @@ -0,0 +1,524 @@ +(define-module (pypi package) + #:use-module (logging logger) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-13) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 hash-table) + #:use-module (ice-9 pretty-print) + #:use-module (guix ui) + #:use-module (guix records) + #:use-module (guix combinators) + #:use-module (guix packages) + #:use-module (gnu packages zip) + #:use-module (guix build-system python) + #:use-module (guix download) + #:use-module (pypi sdist) + #:use-module (pypi sdist-store) + #:use-module (pypi requirement) + #:use-module (pypi dependency-solver) + #:use-module (pypi build-configuration-graph) + #:use-module (guix utils) + #:export (<package-configuration> + package-configuration + package-configuration? + package-configuration-fix-function + package-configuration-python + + requirement->package + requirements->package + + build-configuration-graph->packages + + unsatisfiable-requirements + unsatisfiable-requirements? + get-unsatisfiable-requirements)) + +(define-record-type <package-configuration> + (package-configuration python fix-function) + package-configuration? + (python package-configuration-python) + (fix-function package-configuration-fix-function)) + +(define-record-type <unsatisfiable-requirements> + (unsatisfiable-requirements requirements) + unsatisfiable-requirements? + (requirements get-unsatisfiable-requirements)) + +(define (requirement-options->package + graph + package-configuration + requirement-options-to-versions + requirement-options) + (let + ((build-configuration + (select-build-configuration-from-requirement-options + requirement-options + (or + (hash-ref + requirement-options-to-versions + requirement-options) + (begin + (log-build-configuration-graph 'ERROR graph) + (error "Missing version error for " requirement-options)))))) + (receive (native-inputs inputs propagated-inputs) + (get-inputs + graph + package-configuration + requirement-options-to-versions + (hash-ref + (build-configuration-graph-edges graph) + build-configuration)) + (build-configuration->package + package-configuration + (if (string-contains + (origin-uri + (sdist-source + (build-configuration-sdist build-configuration))) + ".zip") + (cons + `("unzip" ,unzip) + native-inputs) + native-inputs) + inputs + propagated-inputs + build-configuration)))) + +(define (debug-package package) + (log-msg 'DEBUG (package-name package) "@" (package-version package)) + (log-msg 'DEBUG (package-native-inputs package)) + (log-msg 'DEBUG (package-inputs package)) + (log-msg 'DEBUG (package-propagated-inputs package)) + (if (null? (origin-patch-guile (package-source package))) + (error "null patch-guile in own package")) + package) + +(define build-configuration->package + (memoize + (lambda (package-configuration + native-inputs + inputs + propagated-inputs + build-configuration) + (let* + ((sdist (build-configuration-sdist build-configuration)) + (info (sdist-info sdist))) + ((package-configuration-fix-function package-configuration) + sdist + (package + (name (generate-package-name build-configuration)) + (version (pkg-info-version info)) + (source (sdist-source sdist)) + (build-system python-build-system) + (native-inputs native-inputs) + (inputs inputs) + (propagated-inputs propagated-inputs) + (arguments + (append + `(#:python ,(package-configuration-python + package-configuration)) + (if (build-configuration-tests? build-configuration) + '() + `(#:tests? #f)))) + (home-page "") + (synopsis "") + (description (pkg-info-name info)) + (license "") + (properties + `((sdist . ,sdist) + (build-configuration . ,build-configuration))))))))) + +(define (select-build-configuration-from-requirement-options + requirement-options + version) + (or + (find + (lambda (build-configuration) + (equal? + version + (pkg-info-version + (sdist-info + (build-configuration-sdist build-configuration))))) + (requirement-options-options requirement-options)) + (begin + (log-msg 'ERROR "select-build-configuration-from-requirement-options") + (log-msg 'ERROR "version: " version) + (for-each + (lambda (build-configuration) + (let + ((info (sdist-info (build-configuration-sdist build-configuration)))) + (log-msg 'ERROR " " (pkg-info-name info) "@" (pkg-info-version info)))) + (requirement-options-options requirement-options)) + (error "Could not find build-configuration matching version")))) + +(define (get-inputs + graph + package-configuration + requirement-options-to-versions + input-requirement-options) + (apply + values + (map + (lambda (type) + (packages->input-list + (map + (lambda (requirement-options) + (requirement-options->package + graph + package-configuration + requirement-options-to-versions + requirement-options)) + (filter + (lambda (requirement-options) + (eq? type (requirement-options-type requirement-options))) + input-requirement-options)))) + '(build test install)))) + +(define (build-configuration-graph->packages + graph + package-configuration + requirement-options-to-versions) + (map + (lambda (requirement-options) + (requirement-options->package + graph + package-configuration + requirement-options-to-versions + requirement-options)) + (build-configuration-graph-roots graph))) + +(define (requirements->packages + package-configuration + sdist-store + requirements) + (let + ((build-configuration-graph + (requirements->build-configuration-graph + sdist-store + requirements))) + (log-build-configuration-graph 'DEBUG build-configuration-graph) + (let + ((requirement-options-to-versions + (solve-build-configuration-graph + build-configuration-graph))) + (build-configuration-graph->packages + build-configuration-graph + package-configuration + requirement-options-to-versions)))) + +(define (requirement->package + package-configuration + sdist-store + requirement) + (first + (requirements->packages + package-configuration + sdist-store + (list requirement)))) + +(define (memorise-input->package f) + (lambda args + (let* + ((key (list-head args 4)) + (store (second key)) + (store-list (get-sdist-list store))) + + (list-set! key 1 store-list) + (let + ((results (hash-ref input->package-cache key))) + (if results + (apply values results) + (let ((results (call-with-values (lambda () + (apply f args)) + list))) + (hash-set! input->package-cache key results) + (apply values results))))))) + +(define (get-inputs-for-input-requirements ipt dependants dependant-requirements store) + (receive (native-input-requirements + input-requirements + propagated-input-requirements) + (partition-requirements ipt) + (let* + ((new-dependant-requirements + (apply + lset-adjoin + (append + (list equal? propagated-input-requirements) + dependant-requirements))) + (native-input-sdists-and-extras + (get-inputs-for-requirements + store + native-input-requirements + new-dependant-requirements)) + (input-sdists-and-extras + (get-inputs-for-requirements + store + input-requirements + new-dependant-requirements)) + (propagated-input-sdists-and-extras + (get-inputs-for-requirements + store + propagated-input-requirements + new-dependant-requirements)) + (unsatisfied-requirements + (filter + requirement? + (append native-input-sdists-and-extras + input-sdists-and-extras + propagated-input-sdists-and-extras)))) + (values + native-input-sdists-and-extras + input-sdists-and-extras + propagated-input-sdists-and-extras + unsatisfied-requirements + new-dependant-requirements)))) + +(define (get-input-inputs ipt fix-function python dependants dependant-requirements store) + (receive (native-input-inputs + input-inputs + propagated-input-inputs + unsatisfied-requirements + new-dependant-requirements) + (get-inputs-for-input-requirements ipt dependants dependant-requirements store) + (if (not (null? unsatisfied-requirements)) + (throw + unsatisfied-requirements-error + unsatisfied-requirements) + (values + ; native-inputs + (append + (packages->input-list + (input-requirements->packages + ipt + fix-function + python + dependants + new-dependant-requirements + native-input-inputs + store + #f)) + (if (string-contains + (origin-uri (sdist-source (input-sdist ipt))) + ".zip") + `(("unzip" ,unzip)) + '())) + ; inputs + (packages->input-list + (input-requirements->packages + ipt + fix-function + python + dependants + new-dependant-requirements + input-inputs + store + #t)) + ; propagated-inputs + (packages->input-list + (input-requirements->packages + ipt + fix-function + python + dependants + new-dependant-requirements + propagated-input-inputs + store + #t)))))) + +(define (generate-package-name build-configuration) + (let* ((sd (build-configuration-sdist build-configuration)) + (info (sdist-info sd))) + (string-append + (pkg-info-name info) + (if (null? (build-configuration-extras build-configuration)) + "" + (string-append + "+" + (string-join + (stable-sort + (build-configuration-extras build-configuration) + string<?) + "+"))) + (if (build-configuration-tests? build-configuration) + "" + "-no-tests")))) + +(define input->package + (memorise-input->package + ; A package is a function of an sdist, and a list of extras + ; dependants is used to detect dependency loops + (lambda (ipt store fix-function python dependants dependant-requirements) + (let* ((sd (input-sdist ipt)) + (info (sdist-info sd))) + (receive (native-inputs + inputs + propagated-inputs) + (get-input-inputs ipt fix-function python dependants dependant-requirements store) + (fix-function + sd + (package + (name (generate-package-name ipt)) + (version (pkg-info-version info)) + (source (sdist-source sd)) + (build-system python-build-system) + (native-inputs native-inputs) + (inputs inputs) + (propagated-inputs propagated-inputs) + (arguments + (append + `(#:python ,python) + (if (input-run-tests ipt) + '() + `(#:tests? #f)))) + (home-page "") + (synopsis "") + (description (pkg-info-name info)) + (license "") + (properties + `((sdist . ,sd)))))))))) + +(define (input-requirement->package ipt req-input fix-function python dependants dependant-requirements store) + (if (not (dependency-loop? req-input dependants)) + ; no dependency loop detected, so just continue + (input->package + req-input + store + fix-function + python + (cons + ipt + dependants) + dependant-requirements) + ; this package is a dependency on req-input already, so try + ; building it without tests + (let + ((req-input-no-tests + (input + (inherit req-input) + (run-tests #f)))) + (if (not (dependency-loop? req-input-no-tests dependants)) + (input->package + req-input-no-tests + store + fix-function + python + (cons + ipt + dependants) + dependant-requirements) + ; Building without tests has been tried already, and the loop is + ; still present, so try omitting the dependency entirely + (let + ((req-input-no-tests-no-prop + (input + (inherit req-input) + (run-tests #f) + (allow-missing-dependencies + ; Add the current input, but without the allow-missing-dependencies + ; as this is not relevant when deciding what to ignore + (cons (input + (inherit ipt) + (allow-missing-dependencies '())) + (input-allow-missing-dependencies ipt)))))) + (if (and + (not (dependency-loop? + req-input-no-tests-no-prop dependants)) + (not (> (length (input-allow-missing-dependencies ipt)) 4))) + (input->package + req-input-no-tests-no-prop + store + fix-function + python + (cons + ipt + dependants) + dependant-requirements) + (begin + (explain-dependency-loop ipt dependants req-input) + (error "dependency loop detected\n")))))))) + +(define (inputs-equivalent? ipt1 ipt2) + (let* + ((sd1 (input-sdist ipt1)) + (sd2 (input-sdist ipt2)) + (info1 (sdist-info sd1)) + (info2 (sdist-info sd2))) + (and + (equal? (pkg-info-name info1) + (pkg-info-name info2)) + (equal? (pkg-info-version info1) + (pkg-info-version info2))))) + +(define (input-requirements->packages ipt fix-function python dependants dependant-requirements inputs store do-filter) + (log-msg 'DEBUG "input-requirements->packages " (input-short-description ipt)) + (map + (lambda (requirement-ipt) + (input-requirement->package ipt + requirement-ipt + fix-function + python + dependants + dependant-requirements + store)) + ; Filter out any dependencies that are being ignored for this input. + ; If this happens, this is a partial package, being used to break a dependency + ; loop. + (if do-filter + (filter + (lambda (requirement-ipt) + (let* + ((allow-missing (input-allow-missing-dependencies ipt)) + (result + (not + (find + (lambda (ipt2) + (inputs-equivalent? requirement-ipt ipt2)) + allow-missing)))) + (log-msg 'DEBUG + "considering " + (input-short-description requirement-ipt) + " in " (map input-short-description allow-missing) " " result) + result)) + inputs) + inputs))) + +(define input->package-cache (make-hash-table)) + +(define (packages->input-list packages) + (map (lambda (package) + (list (package-name package) package)) + packages)) + +(define (dependency-loop? ipt dependants) + (member ipt dependants)) + +(define (partition-requirements ipt) + ; propagated-inputs-requirements is the install_requirements + ; native-inputs is the + ; (differece + ; (union + ; build requirements + ; test requirements) + ; install_requirements) + (let* + ((sd (input-sdist ipt)) + (propagated-input-requirements + (filter-requirements-by-extras + (sdist-install-requires sd) + (input-extras ipt))) + (native-input-requirements + (lset-difference + equal? + (lset-union + equal? + (sdist-build-requires sd) + (if (input-run-tests ipt) + (sdist-tests-require sd) + '())) + propagated-input-requirements))) + (values + native-input-requirements + '() + propagated-input-requirements))) |