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. --- 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 --------------------------------------- 10 files changed, 5 insertions(+), 558 deletions(-) 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 (limited to 'scripts') 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") -- cgit v1.2.3