Move all generally usable scripts to module dir.

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))
              )