diff options
| -rw-r--r-- | guix/upstream.scm | 64 | ||||
| -rw-r--r-- | tests/upstream.scm | 120 |
2 files changed, 0 insertions, 184 deletions
diff --git a/guix/upstream.scm b/guix/upstream.scm index 7d9ae70eda..53e473715c 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -82,12 +82,6 @@ upstream-updater-predicate upstream-updater-import - upstream-input-change? - upstream-input-change-name - upstream-input-change-type - upstream-input-change-action - changed-inputs - %updaters lookup-updater @@ -151,64 +145,6 @@ its inputs that have the given TYPE (a symbol such as 'native)." (define upstream-source-native-inputs (input-type-filter 'native)) (define upstream-source-propagated-inputs (input-type-filter 'propagated)) -;; Representation of an upstream input change. -(define-record-type* <upstream-input-change> - upstream-input-change make-upstream-input-change - upstream-input-change? - (name upstream-input-change-name) ;string - (type upstream-input-change-type) ;symbol: regular | native | propagated - (action upstream-input-change-action)) ;symbol: add | remove - -(define (changed-inputs package source) - "Return a list of input changes for PACKAGE compared to the 'inputs' field -of SOURCE, an <upstream-source> record." - (define input->name - (match-lambda - ((label (? package? pkg) . out) (package-name pkg)) - (_ #f))) - - (if (upstream-source-inputs source) - (let* ((new-regular (map upstream-input-downstream-name - (upstream-source-regular-inputs source))) - (new-native (map upstream-input-downstream-name - (upstream-source-native-inputs source))) - (new-propagated (map upstream-input-downstream-name - (upstream-source-propagated-inputs source))) - (current-regular - (filter-map input->name (package-inputs package))) - (current-native - (filter-map input->name (package-native-inputs package))) - (current-propagated - (filter-map input->name (package-propagated-inputs package)))) - (append-map - (match-lambda - ((action type names) - (map (lambda (name) - (upstream-input-change - (name name) - (type type) - (action action))) - names))) - `((add regular - ,(lset-difference equal? - new-regular current-regular)) - (remove regular - ,(lset-difference equal? - current-regular new-regular)) - (add native - ,(lset-difference equal? - new-native current-native)) - (remove native - ,(lset-difference equal? - current-native new-native)) - (add propagated - ,(lset-difference equal? - new-propagated current-propagated)) - (remove propagated - ,(lset-difference equal? - current-propagated new-propagated))))) - '())) - (define* (url-predicate matching-url?) "Return a predicate that returns true when passed a package whose source is an <origin> with the URL-FETCH method, and one of its URLs passes diff --git a/tests/upstream.scm b/tests/upstream.scm index 0792ebd5d0..b82579228a 100644 --- a/tests/upstream.scm +++ b/tests/upstream.scm @@ -54,124 +54,4 @@ (signature-urls '("ftp://example.org/foo-1.tar.xz.sig")))))) -(define test-package - (package - (name "test") - (version "2.10") - (source (origin - (method url-fetch) - (uri (string-append "mirror://gnu/hello/hello-" version - ".tar.gz")) - (sha256 - (base32 - "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))) - (build-system gnu-build-system) - (inputs - `(("hello" ,hello))) - (native-inputs - `(("sed" ,sed) - ("tar" ,tar))) - (propagated-inputs - `(("grep" ,grep))) - (home-page "http://localhost") - (synopsis "test") - (description "test") - (license license:gpl3+))) - -(test-equal "changed-inputs returns no changes" - '() - (changed-inputs test-package - (upstream-source - (package "test") - (version "1") - (urls '()) - (inputs - (let ((->input - (lambda (type) - (match-lambda - ((label _) - (upstream-input - (name label) - (downstream-name label) - (type type))))))) - (append (map (->input 'regular) - (package-inputs test-package)) - (map (->input 'native) - (package-native-inputs test-package)) - (map (->input 'propagated) - (package-propagated-inputs - test-package)))))))) - -(define test-new-package - (package - (inherit test-package) - (inputs - (list hello)) - (native-inputs - (list sed tar)) - (propagated-inputs - (list grep)))) - -(test-assert "changed-inputs returns changes to plain input list" - (let ((changes (changed-inputs - (package - (inherit test-new-package) - (inputs (list hello sed)) - (native-inputs '()) - (propagated-inputs '())) - (upstream-source - (package "test") - (version "1") - (urls '()) - (inputs (list (upstream-input - (name "hello") - (downstream-name name)))))))) - (match changes - ;; Exactly one change - (((? upstream-input-change? item)) - (and (equal? (upstream-input-change-type item) - 'regular) - (equal? (upstream-input-change-action item) - 'remove) - (string=? (upstream-input-change-name item) - "sed"))) - (else (pk else #false))))) - -(test-assert "changed-inputs returns changes to all plain input lists" - (let ((changes (changed-inputs - (package - (inherit test-new-package) - (inputs '()) - (native-inputs '()) - (propagated-inputs '())) - (upstream-source - (package "test") - (version "1") - (urls '()) - (inputs (list (upstream-input - (name "hello") - (downstream-name name) - (type 'regular)) - (upstream-input - (name "sed") - (downstream-name name) - (type 'native)) - (upstream-input - (name "tar") - (downstream-name name) - (type 'native)) - (upstream-input - (name "grep") - (downstream-name name) - (type 'propagated)))))))) - (match changes - (((? upstream-input-change? items) ...) - (and (equal? (map upstream-input-change-type items) - '(regular native native propagated)) - (equal? (map upstream-input-change-action items) - '(add add add add)) - (equal? (map upstream-input-change-name items) - '("hello" "sed" "tar" "grep")))) - (else (pk else #false))))) - (test-end) |