From 0c0142881f769b6c42a8a69bec490ba9e98ccf48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 23 Sep 2022 21:01:17 +0200 Subject: Move all generally usable scripts to module dir. --- module/hnh/module-introspection.scm | 22 ++++ module/hnh/module-introspection/all-modules.scm | 55 +++++++++ module/hnh/module-introspection/module-uses.scm | 66 +++++++++++ module/hnh/module-introspection/static-util.scm | 9 ++ module/scripts/README.md | 18 +++ module/scripts/module-dependants.scm | 123 +++++++++++++++++++++ module/scripts/module-imports.scm | 73 ++++++++++++ module/scripts/peg-to-graph.scm | 49 ++++++++ module/scripts/use2dot-all.scm | 141 ++++++++++++++++++++++++ scripts/all-modules.scm | 55 --------- scripts/get-config.scm | 9 +- scripts/input.scm | 2 +- scripts/module-dependants.scm | 127 --------------------- scripts/module-imports.scm | 75 ------------- scripts/module-introspection.scm | 22 ---- scripts/module-uses.scm | 66 ----------- scripts/peg-to-graph.scm | 57 ---------- scripts/static-util.scm | 9 -- scripts/use2dot/gen-use.scm | 141 ------------------------ tests/run-tests.scm | 3 +- 20 files changed, 562 insertions(+), 560 deletions(-) create mode 100644 module/hnh/module-introspection.scm create mode 100644 module/hnh/module-introspection/all-modules.scm create mode 100644 module/hnh/module-introspection/module-uses.scm create mode 100644 module/hnh/module-introspection/static-util.scm create mode 100644 module/scripts/README.md create mode 100755 module/scripts/module-dependants.scm create mode 100755 module/scripts/module-imports.scm create mode 100755 module/scripts/peg-to-graph.scm create mode 100755 module/scripts/use2dot-all.scm delete mode 100644 scripts/all-modules.scm delete mode 100755 scripts/module-dependants.scm delete mode 100755 scripts/module-imports.scm delete mode 100644 scripts/module-introspection.scm delete mode 100644 scripts/module-uses.scm delete mode 100755 scripts/peg-to-graph.scm delete mode 100644 scripts/static-util.scm delete mode 100755 scripts/use2dot/gen-use.scm diff --git a/module/hnh/module-introspection.scm b/module/hnh/module-introspection.scm new file mode 100644 index 00000000..83e561f1 --- /dev/null +++ b/module/hnh/module-introspection.scm @@ -0,0 +1,22 @@ +(define-module (hnh module-introspection) + :use-module (srfi srfi-1) + :use-module (hnh util) + :export (unique-symbols + find-module-declaration + module-declaration? + )) + + +(define (unique-symbols tree) + (uniq + (sort* (filter symbol? (flatten tree)) + stringstring))) + +(define (module-declaration? form) + (cond ((null? form) #f) + ((not (pair? form)) #f) + (else (eq? 'define-module (car form))))) + +(define (find-module-declaration forms) + (and=> (find module-declaration? forms) + cadr)) diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm new file mode 100644 index 00000000..1bf39e1e --- /dev/null +++ b/module/hnh/module-introspection/all-modules.scm @@ -0,0 +1,55 @@ +(define-module (hnh module-introspection all-modules) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (ice-9 ftw) + :use-module (ice-9 match) + :use-module (hnh util path) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (all-files-and-modules-under-directory + all-modules-under-directory + fs-find-base fs-find + module-file-mapping + )) + +(define (fs-find dir) + (define files '()) + (ftw dir (lambda args (set! files (cons args files)) #t)) + files) + +;; (define (fs-find proc dir) +;; (filter proc (fs-find-base dir))) + +(define (all-files-and-modules-under-directory dir) + (define re (make-regexp "\\.scm$")) + + (define files + (map car + (filter (match-lambda ((filename _ 'regular) + (and (regexp-exec re filename) + (not (file-hidden? filename)))) + (_ #f)) + (fs-find dir)))) + + (map (lambda (file) + (list file + (call-with-input-file file + (compose find-module-declaration get-forms)))) + files)) + +(define (all-modules-under-directory dir) + "Returns two values, all scm files in dir, and all top +level modules in those files" + + (define pairs (all-files-and-modules-under-directory dir)) + (values + (map car pairs) + (filter identity (map cadr pairs)))) + +;; Returns an association list from module names the modules +;; containing filename +(define (module-file-mapping dir) + (filter + car + (map (lambda (pair) (cons (cadr pair) (car pair))) + (all-files-and-modules-under-directory dir)))) diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm new file mode 100644 index 00000000..d690f1d7 --- /dev/null +++ b/module/hnh/module-introspection/module-uses.scm @@ -0,0 +1,66 @@ +(define-module (hnh module-introspection module-uses) + :use-module (ice-9 match) + :export (module-uses*)) + +;;; Commentary: +;;; Static analyze version of guile's built in module-uses. +;;; Will give a less accurate result, but in turn doesn't +;;; require that the target module compiles. +;;; Code: + +(define (parse-interface-specification interface-specification) + (match interface-specification + ;; matches `((srfi srfi-1) :select (something)) + (((parts ...) args ...) + parts) + ;; matches `(srfi srfi-1) + ((parts ...) + parts) + (_ (error "Bad module declaration")))) + +;; Finds all define-module forms, and returns what they +;; pull in (including autoloads) +(define (module-declaration-uses forms) + (match forms + (('define-module module-name directives ...) + (let loop ((directives directives)) + (cond ((null? directives) '()) + ((memv (car directives) '(#:use-module #{:use-module}#)) + (cons (parse-interface-specification (cadr directives)) + (loop (cddr directives)))) + ((memv (car directives) '(#:autoload #{:autoload}#)) + (cons (cadr directives) + (loop (cdddr directives)))) + (else (loop (cdr directives)))))) + ((form forms ...) + (append (module-declaration-uses form) + (module-declaration-uses forms))) + (_ '()))) + +;; find all use-modules forms, and return what they pull in +(define (module-use-module-uses forms) + (match forms + (('use-modules modules ...) + (map parse-interface-specification modules)) + ((form forms ...) + (append (module-use-module-uses form) + (module-use-module-uses forms))) + (_ '()))) + +;; find all explicit module references (e.g. +;; (@ (module) var) and (@@ (module) private-var)), +;; and return those modules +(define (module-refer-uses forms) + (match forms + (((or '@ '@@) module _) (list module)) + ((form forms ...) + (append (module-refer-uses form) + (module-refer-uses forms))) + (_ '()))) + +;; List of all modules pulled in in any of forms +(define (module-uses* forms) + (append + (module-declaration-uses forms) + (module-use-module-uses forms) + (module-refer-uses forms))) diff --git a/module/hnh/module-introspection/static-util.scm b/module/hnh/module-introspection/static-util.scm new file mode 100644 index 00000000..7593ce3c --- /dev/null +++ b/module/hnh/module-introspection/static-util.scm @@ -0,0 +1,9 @@ +(define-module (hnh module-introspection static-util) + :export (get-forms)) + +(define (get-forms port) + (let loop ((done '())) + (let ((form (read port))) + (if (eof-object? form) + done + (loop (cons form done)))))) 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 100755 index 00000000..630da519 --- /dev/null +++ b/module/scripts/module-dependants.scm @@ -0,0 +1,123 @@ +;;; 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 (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)))) + +(define (filename-extension? ext) + (let ((re (make-regexp (string-append ((@ (texinfo string-utils) + escape-special-chars) + ext "^$[]()*." #\\) + "$") regexp/icase))) + (lambda (filename) (regexp-exec re 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) + (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)) + ))) + ) + (delete target-file + (filter (filename-extension? ".scm") + (filter regular-file? + (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)) + (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 100755 index 00000000..0639715f --- /dev/null +++ b/module/scripts/module-imports.scm @@ -0,0 +1,73 @@ +;;; 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 "") +(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 (car args)) + (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) + + (define skip-list '((guile) + (guile-user) + (srfi srfi-1) + )) + + + (define modules + (if (null? module-declaration-list) + (map resolve-interface + (remp (lambda (mod) (member mod skip-list)) + (module-uses* forms))) + (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 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 ~%") + (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")) diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm deleted file mode 100644 index 23bbb32d..00000000 --- a/scripts/all-modules.scm +++ /dev/null @@ -1,55 +0,0 @@ -(define-module (all-modules) - :use-module (ice-9 regex) - :use-module (srfi srfi-1) - :use-module (ice-9 ftw) - :use-module (ice-9 match) - :use-module (hnh util path) - :use-module (module-introspection) - :use-module ((static-util) :select (get-forms)) - :export (all-files-and-modules-under-directory - all-modules-under-directory - fs-find-base fs-find - module-file-mapping - )) - -(define (fs-find dir) - (define files '()) - (ftw dir (lambda args (set! files (cons args files)) #t)) - files) - -;; (define (fs-find proc dir) -;; (filter proc (fs-find-base dir))) - -(define (all-files-and-modules-under-directory dir) - (define re (make-regexp "\\.scm$")) - - (define files - (map car - (filter (match-lambda ((filename _ 'regular) - (and (regexp-exec re filename) - (not (file-hidden? filename)))) - (_ #f)) - (fs-find dir)))) - - (map (lambda (file) - (list file - (call-with-input-file file - (compose find-module-declaration get-forms)))) - files)) - -(define (all-modules-under-directory dir) - "Returns two values, all scm files in dir, and all top -level modules in those files" - - (define pairs (all-files-and-modules-under-directory dir)) - (values - (map car pairs) - (filter identity (map cadr pairs)))) - -;; Returns an association list from module names the modules -;; containing filename -(define (module-file-mapping dir) - (filter - car - (map (lambda (pair) (cons (cadr pair) (car pair))) - (all-files-and-modules-under-directory dir)))) diff --git a/scripts/get-config.scm b/scripts/get-config.scm index 2409cfc9..99204941 100755 --- a/scripts/get-config.scm +++ b/scripts/get-config.scm @@ -8,8 +8,7 @@ ;;; Code: -(add-to-load-path "module") -(add-to-load-path "scripts") +(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) (use-modules (hnh util) @@ -18,9 +17,9 @@ (srfi srfi-1) (srfi srfi-88) - (all-modules) - (module-introspection) - ((static-util) + (hnh module-introspection all-modules) + (hnh module-introspection module-introspection) + ((hnh module-introspection static-util) :select (get-forms)) ((calp translation) diff --git a/scripts/input.scm b/scripts/input.scm index 3589a45a..626f5346 100755 --- a/scripts/input.scm +++ b/scripts/input.scm @@ -6,7 +6,7 @@ ;;; `c' to clear screen, `q' to quit. ;;; Code: -(add-to-load-path "module") +(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) (use-modules (vulgar)) (define chrlist '()) diff --git a/scripts/module-dependants.scm b/scripts/module-dependants.scm deleted file mode 100755 index 2880446c..00000000 --- a/scripts/module-dependants.scm +++ /dev/null @@ -1,127 +0,0 @@ -#!/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 -;;; module, and break it down per symbol. -;;; -;;; Code: - -(define module-dir (string-append - (dirname (dirname (current-filename))) - "/module")) - -(add-to-load-path module-dir) -(add-to-load-path (dirname (current-filename))) - - -(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 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)))) - -(define (filename-extension? ext) - (let ((re (make-regexp (string-append ((@ (texinfo string-utils) - escape-special-chars) - ext "^$[]()*." #\\) - "$") regexp/icase))) - (lambda (filename) (regexp-exec re filename)))) - - -(define (main args) - (define target-file (realpath (cadr 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) - (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)) - ))) - ) - (delete target-file - (filter (filename-extension? ".scm") - (filter regular-file? - (find-all-files-under module-dir))))))) - - - (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/scripts/module-imports.scm b/scripts/module-imports.scm deleted file mode 100755 index b7589950..00000000 --- a/scripts/module-imports.scm +++ /dev/null @@ -1,75 +0,0 @@ -#!/usr/bin/guile \ --e main -s -!# - -;;; 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: - -(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*)) - ) - - -;;; Module use high scores -;;; $ grep -Ho '#\?:use-module' -R module | uniq -c | sort -n - -(define (main args) - (define filename (cadr args)) - (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) - - (define skip-list '((guile) - (guile-user) - (srfi srfi-1) - )) - - - (define modules - (if (null? module-declaration-list) - (map resolve-interface - (remp (lambda (mod) (member mod skip-list)) - (module-uses* forms))) - (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/scripts/module-introspection.scm b/scripts/module-introspection.scm deleted file mode 100644 index ba455cfc..00000000 --- a/scripts/module-introspection.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define-module (module-introspection) - :use-module (srfi srfi-1) - :use-module (hnh util) - :export (unique-symbols - find-module-declaration - module-declaration? - )) - - -(define (unique-symbols tree) - (uniq - (sort* (filter symbol? (flatten tree)) - stringstring))) - -(define (module-declaration? form) - (cond ((null? form) #f) - ((not (pair? form)) #f) - (else (eq? 'define-module (car form))))) - -(define (find-module-declaration forms) - (and=> (find module-declaration? forms) - cadr)) diff --git a/scripts/module-uses.scm b/scripts/module-uses.scm deleted file mode 100644 index 220843b6..00000000 --- a/scripts/module-uses.scm +++ /dev/null @@ -1,66 +0,0 @@ -(define-module (module-uses) - :use-module (ice-9 match) - :export (module-uses*)) - -;;; Commentary: -;;; Static analyze version of guile's built in module-uses. -;;; Will give a less accurate result, but in turn doesn't -;;; require that the target module compiles. -;;; Code: - -(define (parse-interface-specification interface-specification) - (match interface-specification - ;; matches `((srfi srfi-1) :select (something)) - (((parts ...) args ...) - parts) - ;; matches `(srfi srfi-1) - ((parts ...) - parts) - (_ (error "Bad module declaration")))) - -;; Finds all define-module forms, and returns what they -;; pull in (including autoloads) -(define (module-declaration-uses forms) - (match forms - (('define-module module-name directives ...) - (let loop ((directives directives)) - (cond ((null? directives) '()) - ((memv (car directives) '(#:use-module #{:use-module}#)) - (cons (parse-interface-specification (cadr directives)) - (loop (cddr directives)))) - ((memv (car directives) '(#:autoload #{:autoload}#)) - (cons (cadr directives) - (loop (cdddr directives)))) - (else (loop (cdr directives)))))) - ((form forms ...) - (append (module-declaration-uses form) - (module-declaration-uses forms))) - (_ '()))) - -;; find all use-modules forms, and return what they pull in -(define (module-use-module-uses forms) - (match forms - (('use-modules modules ...) - (map parse-interface-specification modules)) - ((form forms ...) - (append (module-use-module-uses form) - (module-use-module-uses forms))) - (_ '()))) - -;; find all explicit module references (e.g. -;; (@ (module) var) and (@@ (module) private-var)), -;; and return those modules -(define (module-refer-uses forms) - (match forms - (((or '@ '@@) module _) (list module)) - ((form forms ...) - (append (module-refer-uses form) - (module-refer-uses forms))) - (_ '()))) - -;; List of all modules pulled in in any of forms -(define (module-uses* forms) - (append - (module-declaration-uses forms) - (module-use-module-uses forms) - (module-refer-uses forms))) diff --git a/scripts/peg-to-graph.scm b/scripts/peg-to-graph.scm deleted file mode 100755 index 09a36f06..00000000 --- a/scripts/peg-to-graph.scm +++ /dev/null @@ -1,57 +0,0 @@ -#!/usr/bin/env bash -GUILE=${GUILE:-guile} -set -x -exec $GUILE -e main -s "$0" "$@" -!# - -(add-to-load-path (dirname (current-filename))) -(add-to-load-path (string-append (dirname (current-filename)) "/use2dot")) - - -(use-modules ((graphviz) :prefix #{gv:}#) - ((module-introspection) :select (unique-symbols)) - ((static-util) :select (get-forms)) - (srfi srfi-1) - (ice-9 match)) - -(define peg-primitives - '(and or * + ? followed-by not-followed-by peg-any range - ignore capture peg)) - -(define graph (gv:digraph "G")) - -(define (handle-peg-form 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 (< 2 (length args)) - (format #t "Usage: ~a ~%" (car args)) - (exit 1)) - - (let ((input-file (cadr args))) - (for-each handle-peg-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/scripts/static-util.scm b/scripts/static-util.scm deleted file mode 100644 index 7aa3626e..00000000 --- a/scripts/static-util.scm +++ /dev/null @@ -1,9 +0,0 @@ -(define-module (static-util) - :export (get-forms)) - -(define (get-forms port) - (let loop ((done '())) - (let ((form (read port))) - (if (eof-object? form) - done - (loop (cons form done)))))) diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm deleted file mode 100755 index 6c621fdd..00000000 --- a/scripts/use2dot/gen-use.scm +++ /dev/null @@ -1,141 +0,0 @@ -#!/usr/bin/guile -s -!# - -(add-to-load-path (dirname (current-filename))) -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules ((scripts frisk) :select (make-frisker edge-type edge-up - edge-down)) - (srfi srfi-1) - ((graphviz) :prefix gv.) - (all-modules) - ) - -(define scan (make-frisker `(default-module . (calp main)))) - -(define-values (files our-modules) - (all-modules-under-directory "module")) - -(define graph (gv.digraph "G")) -(gv.setv graph "color" "blue") -(gv.setv graph "compound" "true") -(gv.setv graph "overlap" "prism") -;; (gv.setv graph "bgcolor" "blue") - -(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 (gv.graph graph (format #f "cluster_~a" 0))) - -;; (gv.setv subgraph "rankdir" "TB") -(gv.setv subgraph "color" "Red") - -(define 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 (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))) - - -(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") diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 986d1ac4..ca8f9de4 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -16,7 +16,6 @@ fi (define here (dirname (current-filename))) (use-modules (hnh util path)) -(add-to-load-path (path-append (dirname here) "scripts")) (use-modules (srfi srfi-1) (srfi srfi-64) @@ -34,7 +33,7 @@ fi close-pipe)) ((ice-9 rdelim) :select (read-string)) (system vm coverage) - ((all-modules) :select (fs-find)) + ((hnh module-introspection all-modules) :select (fs-find)) ) -- cgit v1.2.3