;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017 Roel Janssen <roel@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix sets)
- #:use-module (guix packages)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
traverse/depth-first
node-transitive-edges
node-reachable-count
+ shortest-path
%graph-backends
%d3js-backend
0
nodes node-edges))
+(define (shortest-path node1 node2 type)
+ "Return as a monadic value the shortest path, represented as a list, from
+NODE1 to NODE2 of the given TYPE. Return #f when there is no path."
+ (define node-edges
+ (node-type-edges type))
+
+ (define (find-shortest lst)
+ ;; Return the shortest path among LST, where each path is represented as a
+ ;; vlist.
+ (let loop ((lst lst)
+ (best +inf.0)
+ (shortest #f))
+ (match lst
+ (()
+ shortest)
+ ((head . tail)
+ (let ((len (vlist-length head)))
+ (if (< len best)
+ (loop tail len head)
+ (loop tail best shortest)))))))
+
+ (define (find-path node path paths)
+ ;; Return the a vhash that maps nodes to paths, with each path from the
+ ;; given node to NODE2.
+ (define (augment-paths child paths)
+ ;; When using %REFERENCE-NODE-TYPE, nodes can contain self references,
+ ;; hence this test.
+ (if (eq? child node)
+ (store-return paths)
+ (find-path child vlist-null paths)))
+
+ (cond ((eq? node node2)
+ (store-return (vhash-consq node (vlist-cons node path)
+ paths)))
+ ((vhash-assq node paths)
+ (store-return paths))
+ (else
+ ;; XXX: We could stop recursing if one if CHILDREN is NODE2, but in
+ ;; practice it's good enough.
+ (mlet* %store-monad ((children (node-edges node))
+ (paths (foldm %store-monad
+ augment-paths
+ paths
+ children)))
+ (define sub-paths
+ (filter-map (lambda (child)
+ (match (vhash-assq child paths)
+ (#f #f)
+ ((_ . path) path)))
+ children))
+
+ (match sub-paths
+ (()
+ (return (vhash-consq node #f paths)))
+ (lst
+ (return (vhash-consq node
+ (vlist-cons node (find-shortest sub-paths))
+ paths))))))))
+
+ (mlet %store-monad ((paths (find-path node1
+ (vlist-cons node1 vlist-null)
+ vlist-null)))
+ (return (match (vhash-assq node1 paths)
+ ((_ . #f) #f)
+ ((_ . path) (vlist->list path))))))
+
\f
;;;
;;; Graphviz export.
name))
(define (emit-epilogue port)
(display "\n}\n" port))
-(define (emit-node id node port)
- (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
- id (package-full-name node)))
+(define (emit-node id label port)
+ (format port " \"~a\" [label = \"~a\", shape = box, fontname = sans];~%"
+ id label))
(define (emit-edge id1 id2 port)
(format port " \"~a\" -> \"~a\" [color = ~a];~%"
id1 id2 (pop-color id1)))
var nodes = {},
nodeArray = [],
links = [];
-" (search-path %load-path "d3.v3.js")))
+" (search-path %load-path "guix/d3.v3.js")))
(define (emit-d3js-epilogue port)
(format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>"
- (search-path %load-path "graph.js")))
+ (search-path %load-path "guix/graph.js")))
-(define (emit-d3js-node id node port)
+(define (emit-d3js-node id label port)
(format port "\
nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length};
nodeArray.push(nodes[\"~a\"]);~%"
- id id (package-full-name node) id))
+ id id label id))
(define (emit-d3js-edge id1 id2 port)
(format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%"
(define (emit-cypher-epilogue port)
(format port ""))
-(define (emit-cypher-node id node port)
+(define (emit-cypher-node id label port)
(format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%"
- id (package-name node)))
+ id label ))
(define (emit-cypher-edge id1 id2 port)
(format port "MERGE (a:Package { id: ~s });~%" id1)
(ids (mapm %store-monad
node-identifier
dependencies)))
- (emit-node id head port)
+ (emit-node id (node-label head) port)
(for-each (lambda (dependency dependency-id)
(if reverse-edges?
(emit-edge dependency-id id port)