diff options
Diffstat (limited to 'module/scripts')
-rw-r--r-- | module/scripts/README.md | 18 | ||||
-rw-r--r-- | module/scripts/module-dependants.scm | 126 | ||||
-rw-r--r-- | module/scripts/module-imports.scm | 80 | ||||
-rw-r--r-- | module/scripts/peg-to-graph.scm | 63 | ||||
-rw-r--r-- | module/scripts/use2dot-all.scm | 191 |
5 files changed, 478 insertions, 0 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/module/scripts/module-dependants.scm b/module/scripts/module-dependants.scm new file mode 100644 index 00000000..6bda1917 --- /dev/null +++ b/module/scripts/module-dependants.scm @@ -0,0 +1,126 @@ +;;; Commentary: +;;; +;;; For a given module in the project, finds all other modules who uses that +;;; module, and break it down per symbol. +;;; +;;; Code: + +(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 (ice-9 curried-definitions) + :use-module (ice-9 format) + :use-module (texinfo string-utils) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (main)) + +(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? + (lambda (path stat result) #t) + ;; leaf + (lambda (path stat result) + (set! (cstat path) stat) + (cons path result)) + ;; down + (lambda (path stat result) + (set! (cstat path) stat) + (cons path result)) + ;; up + (lambda (path state result) result) + ;; skip + (lambda (path stat result) result) + ;; error + (lambda (path stat errno result) result) + '() directory)) + +(define (regular-file? filename) + (eq? 'regular (stat:type (cstat filename)))) + +;; Does @var{filename} have the extension @var{ext}? +(define ((filename-extension? ext) filename) + (string=? ext (filename-extension filename))) + + +(define (main . args) + (define target-file (realpath (car args))) + (define target-forms + (reverse (call-with-input-file target-file get-forms))) + (define target-module + (find-module-declaration target-forms)) + ;; (define target-symbols (unique-symbols target-forms)) + ;; (write target-module) (newline) + + (define edges + (concatenate + (map (lambda (file) + (catch #t + (lambda () + (define forms (call-with-input-file file get-forms)) + (define module (and=> (-> forms find-module-declaration) resolve-module)) + (define source-symbols (unique-symbols forms)) + + (when module + (awhen (find (lambda (module) + (equal? target-module + (module-name module))) + (module-uses module)) + (let ((module-symbols (module-map (lambda (key value) key) it))) + ;; (display " ") + (map (lambda (symb) + (cons file symb)) + (lset-intersection eq? source-symbols module-symbols)) + )))) + ;; TODO many of these errors are due to the 'prefix and 'postfix + ;; read options being set for modules which expect them to be off. + (lambda (err proc fmt args data) + (format (current-error-port) + "ERROR when reading ~a: ~a in ~a: ~?~%" file err proc fmt args) + '()))) + + (delete target-file + (filter (filename-extension? "scm") + (filter regular-file? + (append-map (lambda (module-dir) + (find-all-files-under module-dir)) + %load-path))))))) + + + (define file-uses (make-hash-table)) + (define symbol-used-by (make-hash-table)) + + (for-each (lambda (edge) + (hashq-set! symbol-used-by (cdr edge) + (cons (car edge) (hashq-ref symbol-used-by (cdr edge) '()))) + (hash-set! file-uses (car edge) + (cons (cdr edge) (hash-ref file-uses (car edge) '())))) + edges) + + (for-each (lambda (pair) + (let ((symb files (car+cdr pair))) + (display (center-string (format #f " ~a (~a uses)" symb (length files)) + 80 #\= #\=)) + (newline) + (for-each (lambda (file) (format #t "• ~a~%" file)) files) + (newline))) + (sort* + (hash-map->list cons symbol-used-by) + string< (compose symbol->string car))) + + (display (center-string " Unused (except possibly internally) " 80 #\= #\=)) (newline) + (for-each (lambda (symb) (format #t "• ~a~%" symb)) + (lset-difference + eqv? + (module-map (lambda (k _) k) (resolve-interface target-module) ) + (hash-map->list (lambda (k _) k) symbol-used-by))) + + ) diff --git a/module/scripts/module-imports.scm b/module/scripts/module-imports.scm new file mode 100644 index 00000000..8f9ab1b8 --- /dev/null +++ b/module/scripts/module-imports.scm @@ -0,0 +1,80 @@ +;;; Commentary: +;;; +;;; Scripts which finds unused imports in each file. +;;; Uses Guile's module system reflection to find what is imported, +;;; but simple looks at all unique symbols in the source file for what +;;; is used, which might lead to some discrepancies. +;;; +;;; Code: + +(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 "List imports, and how many are used.") +(define %synopsis "module-imports filename") + +;;; Module use high scores +;;; $ grep -Ho '#\?:use-module' -R module | uniq -c | sort -n + +(define (main . args) + (define filename (car args)) + ;; TODO Module declaration can reside inside a cond-expand block + (define-values (module-declaration-list forms) + (partition module-declaration? + (reverse (call-with-input-file filename get-forms)))) + + ;; All symbols in source file, which are not in module declaration. + ;; Otherwise all explicitly imported symbols would be marked as + ;; used. + (define symbs (unique-symbols forms)) + ;; (format #t "~y" (find-module-declaration forms)) + ;; (format #t "~a~%" symbs) + + ;; TODO parameterize this to a command line argument + (define skip-list '((guile) + (guile-user) + (srfi srfi-1) + )) + + (define modules + ;; If we didn't find the module declaration + (if (null? module-declaration-list) + ;; Find symbols by best effort + (begin + (format #t "Using our make-shift module introspection~%") + (map (lambda (mod) (apply resolve-interface mod)) + (remp (lambda (mod) (member (car mod) skip-list)) + (module-uses* forms)))) + ;; If we did find the declaration, use the actual symbol in + (begin + (format #t "Using guile's true module introspection~%") + (remp (lambda (mod) (member (module-name mod) skip-list)) + (module-uses (resolve-module + (cadr (car module-declaration-list)))))))) + + (format #t "=== ~a ===~%" filename) + (for-each (lambda (mod) + + ;; all symbols imported from module + (define all-symbols (module-map (lambda (key value) key) mod)) + + ;; Thes subset of all imported symbols from module which are used + (define used-symbols + (filter (lambda (symb) (memv symb symbs)) + all-symbols)) + + (define used-count (length used-symbols)) + (define total-count (length (module-map list mod))) + + (format #t "~a/~a ~a~% used ~s~% unused ~s~%" + used-count total-count (module-name mod) + used-symbols + (lset-difference eq? all-symbols used-symbols))) + modules) + (newline)) diff --git a/module/scripts/peg-to-graph.scm b/module/scripts/peg-to-graph.scm new file mode 100644 index 00000000..afd7a4c3 --- /dev/null +++ b/module/scripts/peg-to-graph.scm @@ -0,0 +1,63 @@ +(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) + :use-module (hnh util options) + :use-module (ice-9 getopt-long) + :export (main)) + +(define option-spec + `((engine (value #t) + (description "Graphviz rendering engine to use. Defaults to DOT")) + (output (single-char #\o) + (value #t) + (description "Name of output pdf")))) + +(define %summary "Output peg-pattern relations as a graphviz graph.") +(define %synopsis "peg-to-graph [options] <filename>") +(define %help (format-arg-help option-spec)) + +(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) + (define options (getopt-long (cons "peg-to-graph" args) + (getopt-opt option-spec))) + (define engine (option-ref options 'engine "dot")) + (define output-file (option-ref options 'output "lex2.pdf")) + (define input-file (let ((filenames (option-ref options '() '()))) + (when (null? filenames) + (format #t "Usage: ~a~%" %summary) + (exit 1)) + (car filenames))) + + + (let ((graph (gv:digraph "G"))) + (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 engine) + (gv:render graph "pdf" output-file))) 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)) |