make-package-tree.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#

(eval-when (:execute)
  (defvar *old-readtable* (copy-readtable))
  (ql:quickload '(:anaphora :s-dot :cl-ppcre :cl-cli) :silent t)
  (use-package :anaphora)
  ;; enable to write as "$node" instead of "s-dot::node"
  (set-macro-character #\$ #'(lambda (stream &rest rest)
                               (declare (ignore rest))
                               (let ((sym (read stream nil)))
                                 (intern (symbol-name sym) "S-DOT")))))

(defstruct package-info
  name
  use-lst
  export-lst
  import-lst)

(defstruct graph-parts
  cluster-lst
  edge-lst)

;; ----- manage family package lists ----- ;;

;; Use a queue rather than a stack because I think that the depth first search (by stack) puts elder nodes in a package tree away.
(defvar *target-pack-queue* nil)
(defvar *processed-pack-list* nil)
(defvar *unprocessed-pack-list* nil)

(defun is-family-pack (pack-name)
  (or (find pack-name *unprocessed-pack-list* :test #'string=)
      (find pack-name *target-pack-queue* :test #'string=)
      (find pack-name *processed-pack-list* :test #'string=)))

(defun queue-pack-name (pack-name)
  (when (find pack-name *unprocessed-pack-list* :test #'string=)
    (setf *unprocessed-pack-list*
          (remove pack-name *unprocessed-pack-list* :test #'string=))
    (setf *target-pack-queue*
          (nreverse (cons pack-name (nreverse *target-pack-queue*))))))

(defun dequeue-pack-name ()
  (cond (*target-pack-queue*
         (alet (pop *target-pack-queue*)
           (push it *processed-pack-list*)
           it))
        (*unprocessed-pack-list*
         (alet (pop *unprocessed-pack-list*)
           (push it *processed-pack-list*)
           it))))

;; load

(defun make-macroexpand-hook-fun (old-hook)
  (lambda (fun form env)
    (when (and (consp form)
               (eq (car form) 'cl:defpackage))
      (pushnew (cadr form) *unprocessed-pack-list*
               :test #'string=))
    (funcall old-hook fun form env)))

(declaim #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(defun load-target-package-list (system-name)
  (let ((*readtable* *old-readtable*))
    (ql:quickload system-name)
    (let ((*macroexpand-hook* (make-macroexpand-hook-fun *macroexpand-hook*))
          (*load-verbose* nil)
          (*load-print* nil)
          (*compile-verbose* nil)
          (*compile-print* nil))
      (asdf:load-system (intern system-name "KEYWORD") :force t))))

(defun exclude-target-list (exclude-list)
  (dolist (pack exclude-list)
    (if (find pack *unprocessed-pack-list*
              :test #'string=)
        (setf *unprocessed-pack-list*
              (delete pack *unprocessed-pack-list*
                      :test #'string=))
        (error "The package \"~A\" is not a package in the system" pack))))

;; ----- process all symbols in a package ----- ;;

(defun interpret-package (target-pack-name)
  (let ((export-lst nil)
        (import-hash (make-hash-table)))
    (do-symbols (sym target-pack-name)
      (let ((pack-name (package-name (symbol-package sym))))
        (queue-pack-name pack-name)
        (cond ((string= pack-name target-pack-name)
               (multiple-value-bind (found type) (find-symbol (symbol-name sym) pack-name)
                 (declare (ignore found))
                 (when (eq type :external)
                   (push sym export-lst))))
              ((is-family-pack pack-name)
               (push sym (gethash pack-name import-hash))))))
    (make-package-info :name target-pack-name
                       :use-lst (mapcar #'package-name
                                        (package-use-list (find-package target-pack-name)))
                       :export-lst export-lst
                       :import-lst import-hash)))

;; ----- make graph ----- ;;

(defvar *replace-list* '(("\\." . "_DOT_")
                         ("\\+" . "_PLUS_")
                         ("\\*" . "_AST_")
                         ("/" . "_SLASH_")
                         ("!" . "_BANG_")
                         ("\\[" . "_LBRACKET_")
                         ("\\]" . "_RBRACKET_")
                         ("\\{" . "_LBRACE_")
                         ("\\}" . "_RBRACE_")
                         ("%" . "_PERCENT_")
                         ("&" . "_AMP_")
                         ("@" . "_AT_")
                         ("=" . "_EQ_")
                         ("-" . "_")
                         (">" . "_GT_")
                         ("<" . "_LT_")))

(defun format-name (name)
  (let ((s-name (if (symbolp name)
                    (symbol-name name)
                    name)))
    (string-upcase
     (let ((formatted s-name))
       (dolist (pair *replace-list*)
         (setf formatted
               (ppcre:regex-replace-all (car pair) formatted (cdr pair))))
       formatted))))

;; In graphviz, because we can't directly draw edges from a cluster,
;; draw them from the 'master' node that has no label, instead.
(defun make-master-node-name (name)
  (format nil "MASTER_~A" (format-name name)))

(defun node (name)
  (alet (format-name name)
    `($node (($id ,it)
             ($label ,it)
             ($width "0.1")
             ($height "0.1")))))

(let* ((color-lst '("red" "blue" "black" "green" "skyblue" "gold" "brown" "gray" "Turquoise"))
       (color-pnt color-lst))
  (defun edge-color ()
    (car color-pnt))
  (defun change-edge-color ()
    (aif (cdr color-pnt)
         (setf color-pnt it)
         (setf color-pnt color-lst))))

(defun edge (from to)
  `($edge (($from ,(format-name from))
           ($to ,(format-name to))
           ($color ,(edge-color)))))

(defun cluster (name node-keyward-lst)
  (let ((s-name (format nil "~A" name)))
    `($cluster (($id ,(format-name s-name))
                ($label ,(format-name (car (last (ppcre:split "\\." s-name))))))
               ($node (($id ,(make-master-node-name s-name))
                       ($label "")
                       ($width "0.1")
                       ($height "0.1")))
               ,@(mapcar #'(lambda (elem) (node (format-name elem)))
                         node-keyward-lst))))

(defun add-info-to-graph (graph pack-info &key (only-package nil))
  (change-edge-color)
  (with-slots (name use-lst export-lst import-lst) pack-info
    (push (cluster name (unless only-package export-lst))
          (graph-parts-cluster-lst graph))
    (slet (graph-parts-edge-lst graph)
      (let ((master-name (make-master-node-name name)))
        (dolist (use (remove-if (lambda (pack-name)
                                  (not (is-family-pack pack-name)))
                                use-lst))
          (push (edge master-name (make-master-node-name use))
                it))
        (maphash (lambda (pack-name sym-lst)
                   (unless (find pack-name use-lst :test #'string=)
                     (if only-package
                         (push (edge master-name (make-master-node-name pack-name))
                               it)
                         (dolist (elem sym-lst)
                           (push (edge master-name elem)
                                 it)))))
                 import-lst))))
  graph)

(defun render-graph (graph file)
  ($render-s-dot file "png"
                 `($graph (($rankdir "LR"))
                          ,@(graph-parts-cluster-lst graph)
                          ,@(graph-parts-edge-lst graph))))

;; ----- getopt ----- ;;

(defvar *only-package*)
(defvar *output*)
(defvar *exclude*)

(defvar *options*
  '((*only-package* nil "Show only packages (doesn't show symbols)" :alias ("-P"))
    (*output* #p"temp.png" "Place the output into <file>" :alias ("-o") :params ("FILE"))
    (*exclude* nil "Exclude packages from graph (if you exclude multiple packages, write them separating by space)" :alias ("-e") :params ("Package names"))))

(defun print-help ()
  (cl-cli:help *options* nil
               :prolog "./make-package-tree.ros [OPTION]... SYSTEM-NAME"))

(defun parse-exclude-target-list (arg-exclude)
  (mapcar #'string-upcase
          (ppcre:split " " arg-exclude)))

(defun parse-args (argv)
  (let ((mod-argv (append (mapcan (lambda (arg)
                                    (if (ppcre:scan "^--" arg)
                                        (ppcre:split "=" arg :limit 2)
                                        (list arg)))
                                  argv))))
    (multiple-value-bind (names vals sub1 sub2 rest)
        ;; Add nil to the head because cl-cli:parce-cli ignore the head of the list
        (cl-cli:parse-cli (cons nil mod-argv) *options*)
      (declare (ignore sub1 sub2))
      (values names vals rest))))

;; ----- main ----- ;; 

(defun main (&rest argv)
  (declare (ignorable argv))
  (unless (> (length argv) 0)
    (print-help)
    (return-from main))
  (multiple-value-bind (names vals rest) (parse-args argv)
    (cl-cli:with-environment names vals
      (let ((system-name (string-upcase (car rest)))
            (graph (make-graph-parts)))
        (load-target-package-list system-name)
        (exclude-target-list (parse-exclude-target-list *exclude*))
        (queue-pack-name system-name)
        (do ((pack-name (dequeue-pack-name) (dequeue-pack-name)))
            ((null pack-name))
          (princ pack-name)
          (terpri)
          (add-info-to-graph graph
                             (interpret-package pack-name)
                             :only-package *only-package*))
        (render-graph graph *output*)
        (format t "~%~%Output to \"~A\"~%" *output*)))))