path: root/pypi/dependency-solver.scm

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