M guix/upstream.scm => guix/upstream.scm +0 -64
@@ 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
M tests/upstream.scm => tests/upstream.scm +0 -120
@@ 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)