path: root/pypi/package.scm

(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)))