doc/dependency-graph.lisp

   1 (defpackage #:trane-dependency-graph
   2   (:use #:common-lisp #:asdf)
   3   (:export #:graph))
   4 (in-package #:trane-dependency-graph)
   5
   6 (defvar *traversed*)
   7 (defvar *indirect*)
   8 (defvar *stream*)
   9
  10 (defun trane-component-p (name)
  11   (or (and (> (length name) 6)
  12            (string= "trane-" (subseq name 0 6)))))
  13
  14 (defun traverse (system &aux (name (component-name system)))
  15   (unless (member name *traversed* :test #'string=)
  16     (push name *traversed*)
  17     (dolist (dep (mapcar #'find-system (rest (assoc 'load-op (component-depends-on 'load-op system)))))
  18       (format *stream* "    ~S -> ~S;~%" name (component-name dep))
  19       (unless (or (string= name "cl-trane")
  20                   (trane-component-p name))
  21         (push (component-name dep) *indirect*))
  22       (traverse dep))))
  23
  24 (defparameter *legend* "
  25     Legend -> \"CL-Trane component\";
  26     \"CL-Trane component\" -> \"Direct dependency\";
  27     \"Direct dependency\" -> \"Indirect dependency\";
  28     Legend [penwidth=4,style=solid,fontsize=16]
  29     \"CL-Trane component\" [penwidth=2,style=solid,fontsize=12]
  30     \"Direct dependency\" [style=solid]
  31 ")
  32
  33 (defun graph-to-stream (s)
  34   (let ((*traversed* nil) (*indirect* nil) (*stream* s))
  35     (format *stream* "digraph \"cl-trane\" {~%    graph[rankdir=LR]~%    node [fontname=\"Helvetica Neue\",fontsize=10,style=dotted];~%")
  36     (traverse (find-system :cl-trane))
  37     (terpri *stream*)
  38     (dolist (dep *traversed*)
  39       (cond
  40         ((trane-component-p dep)
  41          (format *stream* "    ~S [penwidth=2,style=solid,fontsize=12];~%" dep))
  42         ((not (member dep *indirect* :test #'string=))
  43          (format *stream* "    ~S [style=solid];~%" dep))))
  44     (format *stream* "    \"cl-trane\" [penwidth=4,style=solid,fontsize=16];~%~A}~%"
  45             *legend*)))
  46
  47 (defun graph (output-file-name)
  48   (with-open-file (s output-file-name
  49                      :direction :output
  50                      :if-exists :supersede
  51                      :if-does-not-exist :create)
  52     (graph-to-stream s)))