From 8117083b393ca87620a96f9585b790e55c7a14d8 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Thu, 17 Nov 2016 00:37:38 -0500
Subject: [PATCH] Fix ASDF dependency graph generation

---
 dev/examples/class-hierarchy-to-dot.lisp | 59 +++++++++++++-----------
 1 file changed, 31 insertions(+), 28 deletions(-)

diff --git a/dev/examples/class-hierarchy-to-dot.lisp b/dev/examples/class-hierarchy-to-dot.lisp
index 0b586fa..8b0ecbc 100644
--- a/dev/examples/class-hierarchy-to-dot.lisp
+++ b/dev/examples/class-hierarchy-to-dot.lisp
@@ -1,7 +1,7 @@
 (in-package #:metabang.graph)
 
 (defun roots-and-child-function->graph (roots child-function max-depth)
-  (let ((g (make-graph 'graph-container)))
+  (let ((g (make-graph 'dot-graph :vertex-test #'equal)))
     (labels ((init-vertex (vertex depth)
                (when (or (not max-depth) (< depth max-depth))
                  (unless (find-vertex g vertex nil)
@@ -15,19 +15,19 @@
 
 ;;; ---------------------------------------------------------------------------
 
-(defun class-hierarchy->dot (base-class-or-classes output &key (filter (constantly t)))  
-  (metabang.graph:graph->dot 
+(defun class-hierarchy->dot (base-class-or-classes output &key (filter (constantly t)))
+  (metabang.graph:graph->dot
    (roots-and-child-function->graph
     (ensure-list base-class-or-classes)
     (lambda (cname)
       (when (funcall filter cname)
         (mapcar #'class-name (mopu:direct-subclasses (find-class cname)))))
-    nil) 
+    nil)
    output
    :graph-formatter (lambda (g stream)
                       (declare (ignore g))
                       (format stream "rankdir=LR"))
-   
+
    :vertex-labeler (lambda (vertex stream)
                      (format stream "~(~A~)" (symbol-name (element vertex))))
 
@@ -51,27 +51,30 @@
                         containers::circular-iterator-mixin)
                       "thousand-parsers:iterators.dot")
 
-#+(or)
-;; very sucky
-(let ((op (make-instance 'asdf:load-op)))
-  (graph->dot
-   (roots-and-child-function->graph 
-    (list (asdf:find-system 'cl-graph))
-    (lambda (node)
-      (print node)
-      (typecase node
-	(asdf:component
-	 (asdf:component-depends-on op node))
-	(cons
-	 (let ((op (car node)))
-	   (loop for name in (rest node) 
-	      when (asdf:find-system name nil) append
-	     (asdf:component-depends-on op (asdf:find-system name)))))))
-    4)
+;; Use POIU to build a reified ASDF dependency graph.
+(asdf:load-system "poiu") ;; Use POIU for its precise action graph
+
+(in-package :poiu)
+(uiop-debug)
+
+(defun print-action-label (action s)
+  (destructuring-bind (op . c) action
+    (let ((o (if (symbolp op) op (type-of op))))
+      (format s "~(~a~) ~{~a~^ ~}" o (component-find-path c)))))
+
+(defun asdf-dependency-graph (system &optional (max-depth 100))
+  (let* ((system (asdf:find-system system))
+         (op (asdf:make-operation 'asdf:load-op))
+         (plan (make-plan 'parallel-plan op system :force :all)))
+  (cl-graph:graph->dot
+   (cl-graph::roots-and-child-function->graph
+    (list (cons op system))
+    (lambda (action)
+      (if-let (children (action-map (plan-children plan) action)) (action-map-keys children)))
+    max-depth)
    #p"/tmp/out.dot"
-   :vertex-labeler (lambda (v s)
-		     (princ (or (ignore-errors 
-				  (asdf:component-name (element v)))
-				(element v)) s))
-   :edge-labeler (lambda (e s)
-		   (declare (ignore e s)))))
\ No newline at end of file
+   :vertex-labeler (lambda (v s) (print-action-label (cl-graph:element v) s))
+   :edge-labeler (lambda (e s) (declare (ignore e s)) ()))))
+
+(asdf-dependency-graph "fare-csv")
+(uiop:run-program "dot -Tpdf -o /tmp/out.pdf /tmp/out.dot && xpdf /tmp/out.pdf")