From 0c0142881f769b6c42a8a69bec490ba9e98ccf48 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
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 ++++++++++++++++++++++++
 9 files changed, 556 insertions(+)
 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

(limited to 'module')

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))
+          string<? symbol->string)))
+
+(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 <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"))
-- 
cgit v1.2.3