#:use-module (gnu packages)
#:use-module (guix sets)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (%package-node-type
%bag-node-type
+ %bag-with-origins-node-type
%bag-emerged-node-type
%derivation-node-type
%reference-node-type
low))))))
(define (bag-node-edges thing)
- "Return the list of dependencies of THING, a package or origin, etc."
- (if (package? thing)
- (match (bag-direct-inputs (package->bag thing))
- (((labels things . outputs) ...)
- (filter-map (match-lambda
- ((? package? p) p)
- ;; XXX: Here we choose to filter out origins, files,
- ;; etc. Replace "#f" with "x" to reinstate them.
- (x #f))
- things)))
- '()))
+ "Return the list of dependencies of THING, a package or origin.
+Dependencies may include packages, origin, and file names."
+ (cond ((package? thing)
+ (match (bag-direct-inputs (package->bag thing))
+ (((labels things . outputs) ...)
+ things)))
+ ((origin? thing)
+ (cons (origin-patch-guile thing)
+ (if (or (pair? (origin-patches thing))
+ (origin-snippet thing))
+ (match (origin-patch-inputs thing)
+ (#f '())
+ (((labels dependencies _ ...) ...)
+ (delete-duplicates dependencies eq?)))
+ '())))
+ (else
+ '())))
(define %bag-node-type
;; Type for the traversal of package nodes via the "bag" representation,
(description "the DAG of packages, including implicit inputs")
(identifier bag-node-identifier)
(label node-full-name)
- (edges (lift1 bag-node-edges %store-monad))))
+ (edges (lift1 (compose (cut filter package? <>) bag-node-edges)
+ %store-monad))))
+
+(define %bag-with-origins-node-type
+ (node-type
+ (name "bag-with-origins")
+ (description "the DAG of packages and origins, including implicit inputs")
+ (identifier bag-node-identifier)
+ (label node-full-name)
+ (edges (lift1 (lambda (thing)
+ (filter (match-lambda
+ ((? package?) #t)
+ ((? origin?) #t)
+ (_ #f))
+ (bag-node-edges thing)))
+ %store-monad))))
(define standard-package-set
(memoize
;; List of all the node types.
(list %package-node-type
%bag-node-type
+ %bag-with-origins-node-type
%bag-emerged-node-type
%derivation-node-type
%reference-node-type))
(((labels packages) ...)
(map package-full-name packages))))))))
+(test-assert "bag DAG, including origins"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (let* ((m (lambda* (uri hash-type hash name #:key system)
+ (text-file "foo-1.2.3.tar.gz" "This is a fake!")))
+ (o (origin (method m) (uri "the-uri") (sha256 #vu8(0 1 2))))
+ (p (dummy-package "p" (source o))))
+ (run-with-store %store
+ (export-graph (list p) 'port
+ #:node-type %bag-with-origins-node-type
+ #:backend backend))
+ ;; We should see O among the nodes, with an edge coming from P.
+ (let-values (((nodes edges) (nodes+edges)))
+ (run-with-store %store
+ (mlet %store-monad ((o* (lower-object o))
+ (p* (lower-object p)))
+ (return
+ (and (find (match-lambda
+ ((file "the-uri") #t)
+ (_ #f))
+ nodes)
+ (find (match-lambda
+ ((source target)
+ (and (string=? source (derivation-file-name p*))
+ (string=? target o*))))
+ edges)))))))))
+
(test-assert "derivation DAG"
(let-values (((backend nodes+edges) (make-recording-backend)))
(run-with-store %store