path: root/pypi/build-configuration-graph.scm

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