diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-09-23 21:01:17 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-09-23 22:23:47 +0200 |
commit | 0c0142881f769b6c42a8a69bec490ba9e98ccf48 (patch) | |
tree | 515f790266a701a590f04ea589436c54ed3c44b7 /module/scripts | |
parent | Move graphviz to main tree. (diff) | |
download | calp-0c0142881f769b6c42a8a69bec490ba9e98ccf48.tar.gz calp-0c0142881f769b6c42a8a69bec490ba9e98ccf48.tar.xz |
Move all generally usable scripts to module dir.
Diffstat (limited to '')
-rw-r--r-- | module/scripts/README.md | 18 | ||||
-rwxr-xr-x | module/scripts/module-dependants.scm (renamed from scripts/module-dependants.scm) | 46 | ||||
-rwxr-xr-x | module/scripts/module-imports.scm (renamed from scripts/module-imports.scm) | 28 | ||||
-rwxr-xr-x | module/scripts/peg-to-graph.scm | 49 | ||||
-rwxr-xr-x | module/scripts/use2dot-all.scm | 141 |
5 files changed, 242 insertions, 40 deletions
diff --git a/module/scripts/README.md b/module/scripts/README.md new file mode 100644 index 00000000..37bee989 --- /dev/null +++ b/module/scripts/README.md @@ -0,0 +1,18 @@ +Guile Script Format +=================== + +### `%summary` +String containing a summary of what the module does. +Should be a single line. + +### `%include-in-guild-list` +Boolean, indicating if the script should be listed when running `guild help` or `guild list`. + +### `%help` +Longer help for module. If this variable isn't set the procedure `module-commentary` is run + +### `%synopsis` +Short help showing how to invoke the script. Should *not* include the guild command. + +### `main` +Procedure which is primary entry point. Gets remaining command line as its arguments (meaning it takes multiple arguments). diff --git a/scripts/module-dependants.scm b/module/scripts/module-dependants.scm index 2880446c..630da519 100755 --- a/scripts/module-dependants.scm +++ b/module/scripts/module-dependants.scm @@ -1,9 +1,3 @@ -#!/usr/bin/env bash -GUILE=${GUILE:-guile} -set -x -exec $GUILE -e main -s "$0" "$@" -!# - ;;; Commentary: ;;; ;;; For a given module in the project, finds all other modules who uses that @@ -11,26 +5,22 @@ exec $GUILE -e main -s "$0" "$@" ;;; ;;; Code: -(define module-dir (string-append - (dirname (dirname (current-filename))) - "/module")) - -(add-to-load-path module-dir) -(add-to-load-path (dirname (current-filename))) +(define-module (scripts module-dependants) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (ice-9 ftw) + :use-module (texinfo string-utils) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (main)) - -(use-modules (hnh util) - (hnh util path) - (srfi srfi-1) - (srfi srfi-71) - (ice-9 ftw) - (texinfo string-utils) - (module-introspection) - ((static-util) :select (get-forms))) +(define %summary "Print all modules which depend on module specified in target file.") +(define %synopsis "module-dependants TARGET-FILE") (define cstat (make-object-property)) - (define (find-all-files-under directory) (file-system-fold ;; enter? @@ -62,8 +52,8 @@ exec $GUILE -e main -s "$0" "$@" (lambda (filename) (regexp-exec re filename)))) -(define (main args) - (define target-file (realpath (cadr args))) +(define (main . args) + (define target-file (realpath (car args))) (define target-forms (reverse (call-with-input-file target-file get-forms))) (define target-module @@ -93,7 +83,13 @@ exec $GUILE -e main -s "$0" "$@" (delete target-file (filter (filename-extension? ".scm") (filter regular-file? - (find-all-files-under module-dir))))))) + (append-map (lambda (module-dir) + (find-all-files-under module-dir)) + ;; TODO this should be %load-path, but get-forms claims + ;; some files contains invalid syntax. + #; %load-path + '("module") + ))))))) (define file-uses (make-hash-table)) diff --git a/scripts/module-imports.scm b/module/scripts/module-imports.scm index b7589950..0639715f 100755 --- a/scripts/module-imports.scm +++ b/module/scripts/module-imports.scm @@ -1,7 +1,3 @@ -#!/usr/bin/guile \ --e main -s -!# - ;;; Commentary: ;;; ;;; Scripts which finds unused imports in each file. @@ -11,22 +7,24 @@ ;;; ;;; Code: -(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) -(add-to-load-path (dirname (current-filename))) - -(use-modules ((srfi srfi-1) :select (lset-difference)) - ((rnrs lists) :select (remp filter partition)) - ((module-introspection) :select (module-declaration? unique-symbols)) - ((static-util) :select (get-forms)) - ((module-uses) :select (module-uses*)) - ) +(define-module (scripts module-imports) + :use-module ((srfi srfi-1) :select (lset-difference)) + :use-module ((rnrs lists) :select (remp filter partition)) + :use-module ((hnh module-introspection) :select (module-declaration? unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module ((hnh module-introspection module-uses) :select (module-uses*)) + :export (main) + ) +;; (define %summary "") +(define %include-in-guild-list #t) +(define %synopsis "module-imports filename") ;;; Module use high scores ;;; $ grep -Ho '#\?:use-module' -R module | uniq -c | sort -n -(define (main args) - (define filename (cadr args)) +(define (main . args) + (define filename (car args)) (define-values (module-declaration-list forms) (partition module-declaration? (reverse (call-with-input-file filename get-forms)))) diff --git a/module/scripts/peg-to-graph.scm b/module/scripts/peg-to-graph.scm new file mode 100755 index 00000000..0472fd02 --- /dev/null +++ b/module/scripts/peg-to-graph.scm @@ -0,0 +1,49 @@ +(define-module (scripts peg-to-graph) + :use-module ((graphviz) :prefix #{gv:}#) + :use-module ((hnh module-introspection) :select (unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module (srfi srfi-1) + :use-module (ice-9 match) + :export (main)) + +(define %summary "Output peg-pattern relations as a graphviz graph.") +(define %include-in-list #t) + +(define peg-primitives + '(and or * + ? followed-by not-followed-by peg-any range + ignore capture peg)) + +(define (handle-peg-form! graph form) + (match form + (`(define-peg-pattern ,name ,capture ,body) + (let ((node (gv:node graph (format #f "~a" name)))) + (gv:setv node "style" + (case capture + ((all) "solid") + ((body) "dashed") + ((none) "dotted")))) + (for-each (lambda (symbol) + (gv:edge graph + (format #f "~a" name) + (format #f "~a" symbol))) + (remove (lambda (x) (memv x peg-primitives)) + (unique-symbols (list body))))))) + +(define (main . args) + (when (< 1 (length args)) + (format #t "Usage: guild peg-to-graph <filename>~%") + (exit 1)) + + (let ((graph (gv:digraph "G"))) + (let ((input-file (car args))) + (for-each (lambda (form) handle-peg-form! graph form) + (filter (lambda (x) + (and (list? x) + (not (null? x)) + (eq? 'define-peg-pattern (car x)))) + (call-with-input-file input-file get-forms)))) + + (gv:layout graph "dot") + (gv:render graph "pdf" "lex2.pdf") + + (display "done\n"))) diff --git a/module/scripts/use2dot-all.scm b/module/scripts/use2dot-all.scm new file mode 100755 index 00000000..c970d003 --- /dev/null +++ b/module/scripts/use2dot-all.scm @@ -0,0 +1,141 @@ +(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 ((graphviz) :prefix gv.) + :use-module (hnh module-introspection all-modules) + :export (main)) + +(define (main . args) + (define scan (make-frisker `(default-module . (calp main)))) + + (define-values (files our-modules) + (all-modules-under-directory "module")) + + (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)) + + + (define (remove-edges blacklist edges) + (remove (lambda (edge) + (or (member (edge-up edge) blacklist) + (member (edge-down edge) blacklist))) + edges)) + + + + + + (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 '((srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-41) + + (ice-9 match) + (ice-9 format) + + (datetime) + (vcomponent) + (hnh util) + ) + ((scan files) 'edges))) + + (gv.layout graph "fdp") + (gv.render graph "pdf" "graph.pdf") + + + (display "done\n")) |