diff options
Diffstat (limited to 'module/scripts/use2dot-all.scm')
| -rw-r--r-- | module/scripts/use2dot-all.scm | 191 |
1 files changed, 191 insertions, 0 deletions
diff --git a/module/scripts/use2dot-all.scm b/module/scripts/use2dot-all.scm new file mode 100644 index 00000000..18639619 --- /dev/null +++ b/module/scripts/use2dot-all.scm @@ -0,0 +1,191 @@ +(define-module (scripts use2dot-all) + :use-module ((scripts frisk) :select (make-frisker edge-type edge-up + edge-down)) + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) + :use-module ((graphviz) :prefix gv.) + :use-module (hnh module-introspection all-modules) + :use-module (hnh util options) + :use-module (ice-9 getopt-long) + :export (main)) + +(define default-remove + '((srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-41) + + (ice-9 match) + (ice-9 format))) + +(define option-spec + `((engine (value #t) + (description "Graphviz rendering engine to use. Defaults to FDP")) + (default-module + (single-char #\m) + (value #t) + (description "Set MOD as the default module, see guild help use2dot for more information. Defaults to (guile-user)")) + (output + (single-char #\o) + (value #t) + (description "Name of output PDF")) + (remove + (value #t) + (description "Modules to remove from check, usually since to many other modules depend on them.")) + (ignore-default-remove + (description "Don't ignore the modules which are ignored by default, which are:" (br) + ,@(append-map (lambda (item) (list (with-output-to-string (lambda () (display item))) '(br))) + default-remove))))) + +(define %synopsis "use2dot-all [options] <directory>") +(define %summary "Like use2dot, but for multiple modules") +(define %help (format-arg-help option-spec)) + +(define (remove-edges blacklist edges) + (remove (lambda (edge) + (or (member (edge-up edge) blacklist) + (member (edge-down edge) blacklist))) + edges)) + +(define (main . args) + (define options (getopt-long (cons "use2dot-all" args) + (getopt-opt option-spec) + stop-at-first-non-option: #t)) + (define default-module + (cond ((option-ref options 'default-module #f) + => (lambda (s) (let ((mod (with-input-from-string s read))) + (unless (list? mod) + (format (current-error-port) + "Module must be a list: ~s~%" mod) + (exit 1))))) + (else '(guile-user)))) + (define engine (option-ref options 'engine "fdp")) + (define output-file (option-ref options 'output "graph.pdf")) + (define custom-remove (cond ((option-ref options 'remove #f) + => (lambda (s) (let ((lst (with-input-from-string s read))) + (unless (and (list? lst) (every list? lst)) + (format (current-error-port) + "custom-remove must get a list of lists: ~s~%" lst) + (exit 1)) + lst))) + (else '()))) + (define to-remove (if (option-ref options 'default-remove #f) + custom-remove + (append custom-remove default-remove))) + (define target-directory + (let ((remaining (option-ref options '() '()))) + (cond ((null? remaining) + (format (current-error-port) "Target directory required~%") + (exit 1)) + (else (car remaining))))) + + ;; End of command line parsing + + (define scan (make-frisker `(default-module . ,default-module))) + + (define-values (files our-modules) + (all-modules-under-directory target-directory)) + + (define graph + (let ((graph (gv.digraph "G"))) + (gv.setv graph "color" "blue") + (gv.setv graph "compound" "true") + (gv.setv graph "overlap" "prism") + ;; (gv.setv graph "bgcolor" "blue") + graph)) + + (define count 0) + + (define colors + '("red" "green" "blue")) + + (define rem our-modules) + + ;; (for-each (lambda (key) + ;; + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; (define-values (use rem*) (partition (lambda (mod) (eq? key (car mod))) rem)) + ;; (set! rem rem*) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; use) + ;; + ;; (set! count (1+ count)) + ;; ) + ;; '(calp vcomponent)) + + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; rem) + + (define subgraph + (let ((subgraph (gv.graph graph (format #f "cluster_~a" 0)))) + ;; (gv.setv subgraph "rankdir" "TB") + (gv.setv subgraph "color" "Red") + subgraph)) + + + (define subgraphs + (let ((subgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref subgraphs (car name) + (gv.graph graph (format #f "cluster_~a" (car name)))))) + (hashq-set! subgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (lambda (x) (eq? 'calp (car x))) + our-modules)))) + + (define calp-base (gv.graph graph "cluster_1")) + (define calpgraphs + (let ((calpgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref calpgraphs (cadr name) + (gv.graph + ;; calp-base + graph + (format #f "cluster_~a" (cadr name)))))) + (hashq-set! calpgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (compose null? cdr) + (filter (lambda (x) (eq? 'calp (car x))) + our-modules))) + calpgraphs)) + + + (for-each (lambda (edge) + (let ((gv-edge (gv.edge graph + (format #f "~a" (edge-down edge)) + (format #f "~a" (edge-up edge)) + ))) + (when (and (eq? 'calp (car (edge-up edge))) + (not (eq? 'calp (car (edge-down edge))))) + (gv.setv gv-edge "color" "red")) + (when (and (memv (car (edge-up edge)) '(vcomponent calp)) + (not (memv (car (edge-down edge)) '(vcomponent calp )))) + (gv.setv gv-edge "color" "blue")) + )) + (remove-edges to-remove + ((scan files) 'edges))) + + (gv.layout graph engine) + (gv.render graph "pdf" output-file)) |