;;; 
;;; graph.lisp
;;; 
;;; Created: 2003-12-22 by Zach Beane <xach@gwi.net>
;;; 
;;; **PURPOSE**
;;; 
;;; 
;;; $Id$

(defpackage "ASDF-GRAPH"
  (:use "CL"))

(in-package "ASDF-GRAPH")

(defvar *load-op* (make-instance 'asdf::load-op))

(defun maybe-quote (string)
  "If STRING contains non-identifier characters, return it
  surrounded by double-quotes, otherwise return it directly."
  (if (or (find #\- string) (find #\/ string))
      (format nil "\"~A\"" string)
      string))

(defun node-name (string)
  (maybe-quote (if *node-prefix*
                   (format nil "~A_~A" *node-prefix* string)
                   string)))



(defmethod dependencies (item)
  nil)

(defmethod dependencies ((item asdf::component))
  (let ((depend-operation-list (cdr (asdf:component-depends-on *load-op*
                                                               item))))
    (when depend-operation-list
      (let ((deps nil))
        (dolist (depend-op depend-operation-list deps)
          (dolist (component (cdr depend-op))
            (when (stringp component)
              (push component deps))))))))
      

(defun make-edge (from to)
  (format t "~&~A -> ~A;~%" (node-name from) (node-name to)))

(defvar *node-prefix* nil)

(defun make-node (name &key (shape nil))
  (format t "~&~A [label=\"~A\"" (node-name name) name)
  (when shape
    (format t ",shape=~A" shape))
  (format t "];~%"))
          


(defmacro with-subgraph (name &body body)
  (let ((subgraph-name (gensym)))
    `(let* ((,subgraph-name ,name)
            (*node-prefix* ,subgraph-name))
       (format t "~&subgraph \"cluster~A\" {~%" ,subgraph-name)
       (format t "label=\"~A\";~%" ,subgraph-name)
       ,@body
       (format t "~&};~%"))))



(defgeneric dot-graph (item))

(defmethod dot-graph ((item asdf::system))
  (format t "~&digraph ~A {~%" (maybe-quote (asdf:component-name item)))
  (format t "rankdir=LR;~%")
  (dolist (component (asdf:module-components item))
    (dot-graph component))
  (format t "~&}~%"))




(defmethod dot-graph ((item asdf::module))
  (let ((name (asdf:component-name item)))
    (make-node name :shape "box")
    (with-subgraph name
      (dolist (component (asdf:module-components item))
        (dot-graph component)))))



(defmethod dot-graph ((item asdf::component))
  (let ((name (asdf:component-name item)))
    (make-node name)
    (dolist (dep (dependencies item))
      (make-edge name dep))))
             


(defun make-dot-file (system-name)
  (let ((system (asdf:find-system system-name nil))
        (output-file (format nil "~A.dot" system-name)))
    (when system
      (with-open-file (*standard-output* output-file :direction :output)
        (dot-graph system))
      (format t "; wrote ~A~%" output-file))))