(define-module (pypi sdist)
  #:use-module (logging logger)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-13)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (guix ui)
  #:use-module (guix base32)
  #:use-module (guix records)
  #:use-module (guix download)
  #:use-module (guix packages)
  #:use-module (pypi requirement)
  #:use-module (pypi utils)
  #:export (sdist
            sdist?
            sdist-info
            sdist-build-requires
            sdist-tests-require
            sdist-install-requires
            sdist-extras-require
            sdist-source

            sdist-short-description

            get-quoted-sdist
            sdist-meets-requirement
            add-build-requirements-to-sdist
            add-test-requirements-to-sdist

            pkg-info
            pkg-info?
            pkg-info-name
            pkg-info-version
            pkg-info-home-page
            pkg-info-synopsis
            pkg-info-description
            pkg-info-license

            get-quoted-pkg-info

            get-extra-combinations
            get-requirements-for-extras

            extra
            extra?
            extra-name
            extra-requires))

(define-record-type* <sdist>
  sdist make-sdist
  sdist?
  (info              sdist-info)
  (build-requires    sdist-build-requires
                     (default '()))
  (tests-require     sdist-tests-require
                     (default '()))
  (install-requires  sdist-install-requires
                     (default '()))
  (extras-require    sdist-extras-require
                     (default '()))
  (source            sdist-source))

(define (get-quoted-sdist sdist)
  `(sdist
     (info ,(get-quoted-pkg-info (sdist-info sdist)))
     (build-requires ,(append '(list)
                              (map get-quoted-requirement
                                   (sdist-build-requires sdist))))
     (tests-require ,(append '(list)
                             (map get-quoted-requirement
                                  (sdist-tests-require sdist))))
     (install-requires ,(append '(list)
                                (map get-quoted-requirement
                                     (sdist-install-requires sdist))))
     (extras-require ,(append '(list)
                              (map
                                get-quoted-extra
                                (sdist-extras-require sdist))))
     (source ,(get-quoted-origin (sdist-source sdist)))))

(define (add-build-requirements-to-sdist sd reqs)
  (let
    ((duplicate
       (any
         (lambda (r)
           (member r (sdist-build-requires sd)))
         reqs)))
    (if duplicate
      (error "Cannot add duplicate build requirement " duplicate)))
  (log-msg 'INFO
     "Adding build requirements to "
     (sdist-short-description sd)
     " " reqs)
  (sdist
    (inherit sd)
    (build-requires
      (append
        (sdist-build-requires sd)
        reqs))))

(define (add-test-requirements-to-sdist sd reqs)
  (log-msg 'INFO
     "Adding test requirements to "
     (sdist-short-description sd)
     " " reqs)
  (let
    ((duplicate
       (any
         (lambda (r)
           (member r (sdist-tests-require sd)))
         reqs)))
    (if duplicate
      (error "Cannot add duplicate test requirement " duplicate)))
  (sdist
    (inherit sd)
    (tests-require
      (append
        (sdist-tests-require sd)
        reqs))))

(define (get-quoted-origin o)
  `(origin
     (method ,(let
                 ((m (origin-method o)))
                 (cond
                   ((eqv? url-fetch m)
                      'url-fetch)
                   (else
                     (report-error (_ "unknown method ") m "\n")))))
     (uri ,(origin-uri o))
     (sha256
       (base32
         ,(bytevector->nix-base32-string (origin-sha256 o))))))

(define-record-type* <pkg-info>
  pkg-info make-pkg-info
  pkg-info?
  (name  pkg-info-name)
  (version  pkg-info-version)
  (home-page  pkg-info-home-page)
  (synopsis  pkg-info-synopsis)
  (description  pkg-info-description)
  (license  pkg-info-license))

(define (get-quoted-pkg-info pi)
  `(pkg-info
     (name ,(pkg-info-name pi))
     (version ,(pkg-info-version pi))
     (home-page ,(pkg-info-home-page pi))
     (synopsis ,(pkg-info-synopsis pi))
     (description ,(pkg-info-description pi))
     (license ,(pkg-info-license pi))))

(define (get-extra-combinations sdist)
  (all-combinations
    (sdist-extras-require sdist)))

(define (get-requirements-for-extras sd extras)
  (apply
    append
    (map
      (lambda (extra)
        (assoc-ref extra (sdist-extras-require sd)))
      extras)))


(define (sdist-meets-requirement sd r)
  (version-meets-requirement r
                             (pkg-info-version (sdist-info sd))))

(define-record-type <extra>
  (extra name requirements)
  extra?
  (name extra-name)
  (requirements extra-requires))

(define (get-quoted-extra e)
  `(extra
     ,(extra-name e)
     ,(append '(list)
        (map get-quoted-requirement
        (extra-requires e)))))

(define (sdist-short-description sd)
  (let
    ((info (sdist-info sd)))
    (string-append
      (pkg-info-name info)
      "@"
      (pkg-info-version info))))