Move all generally usable scripts to module dir.

10 files changed, 5 insertions, 558 deletions

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