diff options
-rw-r--r-- | module/hnh/module-introspection.scm (renamed from scripts/module-introspection.scm) | 2 | ||||
-rw-r--r-- | module/hnh/module-introspection/all-modules.scm (renamed from scripts/all-modules.scm) | 6 | ||||
-rw-r--r-- | module/hnh/module-introspection/module-uses.scm (renamed from scripts/module-uses.scm) | 2 | ||||
-rw-r--r-- | module/hnh/module-introspection/static-util.scm (renamed from scripts/static-util.scm) | 2 | ||||
-rw-r--r-- | module/scripts/README.md | 18 | ||||
-rwxr-xr-x | module/scripts/module-dependants.scm (renamed from scripts/module-dependants.scm) | 46 | ||||
-rwxr-xr-x | module/scripts/module-imports.scm (renamed from scripts/module-imports.scm) | 28 | ||||
-rwxr-xr-x | module/scripts/peg-to-graph.scm | 49 | ||||
-rwxr-xr-x | module/scripts/use2dot-all.scm | 141 | ||||
-rwxr-xr-x | scripts/get-config.scm | 9 | ||||
-rwxr-xr-x | scripts/input.scm | 2 | ||||
-rwxr-xr-x | scripts/peg-to-graph.scm | 57 | ||||
-rwxr-xr-x | scripts/use2dot/gen-use.scm | 141 | ||||
-rwxr-xr-x | tests/run-tests.scm | 3 |
14 files changed, 254 insertions, 252 deletions
diff --git a/scripts/module-introspection.scm b/module/hnh/module-introspection.scm index ba455cfc..83e561f1 100644 --- a/scripts/module-introspection.scm +++ b/module/hnh/module-introspection.scm @@ -1,4 +1,4 @@ -(define-module (module-introspection) +(define-module (hnh module-introspection) :use-module (srfi srfi-1) :use-module (hnh util) :export (unique-symbols diff --git a/scripts/all-modules.scm b/module/hnh/module-introspection/all-modules.scm index 23bbb32d..1bf39e1e 100644 --- a/scripts/all-modules.scm +++ b/module/hnh/module-introspection/all-modules.scm @@ -1,11 +1,11 @@ -(define-module (all-modules) +(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 (module-introspection) - :use-module ((static-util) :select (get-forms)) + :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 diff --git a/scripts/module-uses.scm b/module/hnh/module-introspection/module-uses.scm index 220843b6..d690f1d7 100644 --- a/scripts/module-uses.scm +++ b/module/hnh/module-introspection/module-uses.scm @@ -1,4 +1,4 @@ -(define-module (module-uses) +(define-module (hnh module-introspection module-uses) :use-module (ice-9 match) :export (module-uses*)) diff --git a/scripts/static-util.scm b/module/hnh/module-introspection/static-util.scm index 7aa3626e..7593ce3c 100644 --- a/scripts/static-util.scm +++ b/module/hnh/module-introspection/static-util.scm @@ -1,4 +1,4 @@ -(define-module (static-util) +(define-module (hnh module-introspection static-util) :export (get-forms)) (define (get-forms port) diff --git a/module/scripts/README.md b/module/scripts/README.md new file mode 100644 index 00000000..37bee989 --- /dev/null +++ b/module/scripts/README.md @@ -0,0 +1,18 @@ +Guile Script Format +=================== + +### `%summary` +String containing a summary of what the module does. +Should be a single line. + +### `%include-in-guild-list` +Boolean, indicating if the script should be listed when running `guild help` or `guild list`. + +### `%help` +Longer help for module. If this variable isn't set the procedure `module-commentary` is run + +### `%synopsis` +Short help showing how to invoke the script. Should *not* include the guild command. + +### `main` +Procedure which is primary entry point. Gets remaining command line as its arguments (meaning it takes multiple arguments). diff --git a/scripts/module-dependants.scm b/module/scripts/module-dependants.scm index 2880446c..630da519 100755 --- a/scripts/module-dependants.scm +++ b/module/scripts/module-dependants.scm @@ -1,9 +1,3 @@ -#!/usr/bin/env bash -GUILE=${GUILE:-guile} -set -x -exec $GUILE -e main -s "$0" "$@" -!# - ;;; Commentary: ;;; ;;; For a given module in the project, finds all other modules who uses that @@ -11,26 +5,22 @@ exec $GUILE -e main -s "$0" "$@" ;;; ;;; Code: -(define module-dir (string-append - (dirname (dirname (current-filename))) - "/module")) - -(add-to-load-path module-dir) -(add-to-load-path (dirname (current-filename))) +(define-module (scripts module-dependants) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (ice-9 ftw) + :use-module (texinfo string-utils) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (main)) - -(use-modules (hnh util) - (hnh util path) - (srfi srfi-1) - (srfi srfi-71) - (ice-9 ftw) - (texinfo string-utils) - (module-introspection) - ((static-util) :select (get-forms))) +(define %summary "Print all modules which depend on module specified in target file.") +(define %synopsis "module-dependants TARGET-FILE") (define cstat (make-object-property)) - (define (find-all-files-under directory) (file-system-fold ;; enter? @@ -62,8 +52,8 @@ exec $GUILE -e main -s "$0" "$@" (lambda (filename) (regexp-exec re filename)))) -(define (main args) - (define target-file (realpath (cadr args))) +(define (main . args) + (define target-file (realpath (car args))) (define target-forms (reverse (call-with-input-file target-file get-forms))) (define target-module @@ -93,7 +83,13 @@ exec $GUILE -e main -s "$0" "$@" (delete target-file (filter (filename-extension? ".scm") (filter regular-file? - (find-all-files-under module-dir))))))) + (append-map (lambda (module-dir) + (find-all-files-under module-dir)) + ;; TODO this should be %load-path, but get-forms claims + ;; some files contains invalid syntax. + #; %load-path + '("module") + ))))))) (define file-uses (make-hash-table)) diff --git a/scripts/module-imports.scm b/module/scripts/module-imports.scm index b7589950..0639715f 100755 --- a/scripts/module-imports.scm +++ b/module/scripts/module-imports.scm @@ -1,7 +1,3 @@ -#!/usr/bin/guile \ --e main -s -!# - ;;; Commentary: ;;; ;;; Scripts which finds unused imports in each file. @@ -11,22 +7,24 @@ ;;; ;;; Code: -(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) -(add-to-load-path (dirname (current-filename))) - -(use-modules ((srfi srfi-1) :select (lset-difference)) - ((rnrs lists) :select (remp filter partition)) - ((module-introspection) :select (module-declaration? unique-symbols)) - ((static-util) :select (get-forms)) - ((module-uses) :select (module-uses*)) - ) +(define-module (scripts module-imports) + :use-module ((srfi srfi-1) :select (lset-difference)) + :use-module ((rnrs lists) :select (remp filter partition)) + :use-module ((hnh module-introspection) :select (module-declaration? unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module ((hnh module-introspection module-uses) :select (module-uses*)) + :export (main) + ) +;; (define %summary "") +(define %include-in-guild-list #t) +(define %synopsis "module-imports filename") ;;; Module use high scores ;;; $ grep -Ho '#\?:use-module' -R module | uniq -c | sort -n -(define (main args) - (define filename (cadr args)) +(define (main . args) + (define filename (car args)) (define-values (module-declaration-list forms) (partition module-declaration? (reverse (call-with-input-file filename get-forms)))) diff --git a/module/scripts/peg-to-graph.scm b/module/scripts/peg-to-graph.scm new file mode 100755 index 00000000..0472fd02 --- /dev/null +++ b/module/scripts/peg-to-graph.scm @@ -0,0 +1,49 @@ +(define-module (scripts peg-to-graph) + :use-module ((graphviz) :prefix #{gv:}#) + :use-module ((hnh module-introspection) :select (unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module (srfi srfi-1) + :use-module (ice-9 match) + :export (main)) + +(define %summary "Output peg-pattern relations as a graphviz graph.") +(define %include-in-list #t) + +(define peg-primitives + '(and or * + ? followed-by not-followed-by peg-any range + ignore capture peg)) + +(define (handle-peg-form! graph form) + (match form + (`(define-peg-pattern ,name ,capture ,body) + (let ((node (gv:node graph (format #f "~a" name)))) + (gv:setv node "style" + (case capture + ((all) "solid") + ((body) "dashed") + ((none) "dotted")))) + (for-each (lambda (symbol) + (gv:edge graph + (format #f "~a" name) + (format #f "~a" symbol))) + (remove (lambda (x) (memv x peg-primitives)) + (unique-symbols (list body))))))) + +(define (main . args) + (when (< 1 (length args)) + (format #t "Usage: guild peg-to-graph <filename>~%") + (exit 1)) + + (let ((graph (gv:digraph "G"))) + (let ((input-file (car args))) + (for-each (lambda (form) handle-peg-form! graph form) + (filter (lambda (x) + (and (list? x) + (not (null? x)) + (eq? 'define-peg-pattern (car x)))) + (call-with-input-file input-file get-forms)))) + + (gv:layout graph "dot") + (gv:render graph "pdf" "lex2.pdf") + + (display "done\n"))) diff --git a/module/scripts/use2dot-all.scm b/module/scripts/use2dot-all.scm new file mode 100755 index 00000000..c970d003 --- /dev/null +++ b/module/scripts/use2dot-all.scm @@ -0,0 +1,141 @@ +(define-module (scripts use2dot-all) + :use-module ((scripts frisk) :select (make-frisker edge-type edge-up + edge-down)) + :use-module (srfi srfi-1) + :use-module ((graphviz) :prefix gv.) + :use-module (hnh module-introspection all-modules) + :export (main)) + +(define (main . args) + (define scan (make-frisker `(default-module . (calp main)))) + + (define-values (files our-modules) + (all-modules-under-directory "module")) + + (define graph + (let ((graph (gv.digraph "G"))) + (gv.setv graph "color" "blue") + (gv.setv graph "compound" "true") + (gv.setv graph "overlap" "prism") + ;; (gv.setv graph "bgcolor" "blue") + graph)) + + (define count 0) + + (define colors + '("red" "green" "blue")) + + (define rem our-modules) + + ;; (for-each (lambda (key) + ;; + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; (define-values (use rem*) (partition (lambda (mod) (eq? key (car mod))) rem)) + ;; (set! rem rem*) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; use) + ;; + ;; (set! count (1+ count)) + ;; ) + ;; '(calp vcomponent)) + + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; rem) + + (define subgraph + (let ((subgraph (gv.graph graph (format #f "cluster_~a" 0)))) + ;; (gv.setv subgraph "rankdir" "TB") + (gv.setv subgraph "color" "Red") + subgraph)) + + + (define subgraphs + (let ((subgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref subgraphs (car name) + (gv.graph graph (format #f "cluster_~a" (car name)))))) + (hashq-set! subgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (lambda (x) (eq? 'calp (car x))) + our-modules)))) + + (define calp-base (gv.graph graph "cluster_1")) + (define calpgraphs + (let ((calpgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref calpgraphs (cadr name) + (gv.graph + ;; calp-base + graph + (format #f "cluster_~a" (cadr name)))))) + (hashq-set! calpgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (compose null? cdr) + (filter (lambda (x) (eq? 'calp (car x))) + our-modules))) + calpgraphs)) + + + (define (remove-edges blacklist edges) + (remove (lambda (edge) + (or (member (edge-up edge) blacklist) + (member (edge-down edge) blacklist))) + edges)) + + + + + + (for-each (lambda (edge) + (let ((gv-edge (gv.edge graph + (format #f "~a" (edge-down edge)) + (format #f "~a" (edge-up edge)) + ))) + (when (and (eq? 'calp (car (edge-up edge))) + (not (eq? 'calp (car (edge-down edge))))) + (gv.setv gv-edge "color" "red")) + (when (and (memv (car (edge-up edge)) '(vcomponent calp)) + (not (memv (car (edge-down edge)) '(vcomponent calp )))) + (gv.setv gv-edge "color" "blue")) + )) + (remove-edges '((srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-41) + + (ice-9 match) + (ice-9 format) + + (datetime) + (vcomponent) + (hnh util) + ) + ((scan files) 'edges))) + + (gv.layout graph "fdp") + (gv.render graph "pdf" "graph.pdf") + + + (display "done\n")) 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/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 <filename>~%" (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/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)) ) |