aboutsummaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'scripts')
-rw-r--r--scripts/all-modules.scm44
-rwxr-xr-xscripts/fetch-liu-map-index.scm65
-rwxr-xr-xscripts/generate-test-data.scm4
-rwxr-xr-xscripts/get-config.scm9
-rwxr-xr-xscripts/input.scm2
-rwxr-xr-xscripts/module-dependants.scm126
-rwxr-xr-xscripts/module-imports.scm65
-rw-r--r--scripts/module-introspection.scm43
-rwxr-xr-xscripts/set-version2
-rwxr-xr-xscripts/use2dot-all.sh8
-rwxr-xr-xscripts/use2dot/gen-use.scm141
-rw-r--r--scripts/use2dot/graphviz.scm84
12 files changed, 59 insertions, 534 deletions
diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm
deleted file mode 100644
index b83644e5..00000000
--- a/scripts/all-modules.scm
+++ /dev/null
@@ -1,44 +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)
- :export (all-files-and-modules-under-directory
- all-modules-under-directory
- fs-find-base fs-find))
-
-(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))))
diff --git a/scripts/fetch-liu-map-index.scm b/scripts/fetch-liu-map-index.scm
index 31db3844..2ac300e1 100755
--- a/scripts/fetch-liu-map-index.scm
+++ b/scripts/fetch-liu-map-index.scm
@@ -19,35 +19,54 @@
(ice-9 getopt-long)
(sxml gumbo)
(sxml match)
- ((hnh util) :select (->))
+ ((sxml xpath) :select (sxpath))
+ ((hnh util) :select (-> ->>))
(json))
+;; Fallback to ensure we have HTTPS
+(define http-get
+ (catch 'gnutls-not-available
+ (lambda ()
+ ((@@ (web client) ensure-gnutls))
+ (@ (web client) http-get))
+ (lambda _
+ (use-modules (ice-9 popen)
+ (web http))
+
+ (lambda (url . _)
+ (let ((pipe (open-pipe* OPEN_READ "curl" "--include" "--http1.1" url)))
+ (let ((intro (string-split (read-line pipe) #\space)) ; HTTP/1.1 200 OK\r
+ (headers (read-headers pipe)))
+ (let ((response
+ (build-response
+ version: (parse-http-version (list-ref intro 0))
+ code: (string->number (list-ref intro 1))
+ reason-phrase: (string-trim-right
+ (string-join (drop intro 2) " " 'infix)
+ char-whitespace?)
+ headers: headers
+ port: pipe
+ validate-headers?: #t)))
+ (values response pipe))))))))
;; Parse string as HTML, find all links which are "map links",
;; and return them as an association list from name to url-fragments.
-(define (get-data string)
- (define data (html->sxml string))
-
+(define (extract-data string)
(define rx (make-regexp "^karta\\?"))
- (define links
- (map (lambda (node)
- (sxml-match node
- [(a (@ (href ,href)) ,b0 ,body ...)
- (cons href b0)]))
- (((@ (sxml xpath) sxpath) '(// a)) data)))
-
- (define map-links (filter (lambda (pair) (regexp-exec rx (car pair)))
- links))
-
- (define link-table (make-hash-table))
- (for-each (lambda (pair) (hash-set! link-table (string-upcase (string-trim-both (cdr pair)))
- (car pair)))
- map-links)
+ ;; for (let el of document.querySelectorAll('a[href*="karta?"]')) {
+ ;; ret[el.textContent.trim().toUpperCase()] = el.href
+ ;; }
- (hash-map->list (lambda (name frag)
- `(,name . ,frag))
- link-table))
+ (->> (html->sxml string)
+ ((sxpath '(// a)))
+ (map (lambda (node)
+ (sxml-match node
+ [(a (@ (href ,href)) ,b0 ,body ...)
+ (cons href b0)])))
+ (filter (lambda (pair) (regexp-exec rx (car pair))))
+ (map (lambda (pair) (cons (string-upcase (string-trim-both (cdr pair)))
+ (car pair))))))
;; Open a HTTP request to the given URL, and return the
;; response body as a port.
@@ -85,9 +104,9 @@
(let ((port
(cond ((option-ref options 'url #f) => open-input-url)
- ((and=> (option-ref options 'file #f) (lambda (s) (string=? s "-")))
+ ((string=? "-" (option-ref options 'file ""))
(current-input-port))
((option-ref options 'file #f) => open-input-file)
(else (open-input-url "https://old.liu.se/karta/list?l=sv")))))
- (-> port read-string get-data scm->json)
+ (-> port read-string extract-data scm->json)
(newline)))
diff --git a/scripts/generate-test-data.scm b/scripts/generate-test-data.scm
index 076558e4..b80c4994 100755
--- a/scripts/generate-test-data.scm
+++ b/scripts/generate-test-data.scm
@@ -63,8 +63,8 @@
(prop cal 'PRODID) "-//hugo//calp TEST//EN"
(prop cal 'VERSION) "2.0")
-(add-child! cal zoneinfo)
-(add-child! cal ev)
+(reparent! cal zoneinfo)
+(reparent! cal ev)
(define sxcal
`(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
diff --git a/scripts/get-config.scm b/scripts/get-config.scm
index 7d6abfcd..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,8 +17,10 @@
(srfi srfi-1)
(srfi srfi-88)
- (all-modules)
- (module-introspection)
+ (hnh module-introspection all-modules)
+ (hnh module-introspection module-introspection)
+ ((hnh module-introspection static-util)
+ :select (get-forms))
((calp translation)
:select (translate))
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 87c1f40b..00000000
--- a/scripts/module-dependants.scm
+++ /dev/null
@@ -1,126 +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))
-
-(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 6a0a5beb..00000000
--- a/scripts/module-imports.scm
+++ /dev/null
@@ -1,65 +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 (hnh util)
- ((srfi srfi-1) :select (lset-difference))
- (rnrs lists)
- (module-introspection))
-
-
-;;; Module use high scores
-;;; $ grop -Ho '#\?:use-module' -R module | uniq -c | sort -n
-
-(define (main args)
- (define filename (cadr args))
- (define-values (module-declaration-lst 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)
-
- (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)))
-
- (remp (lambda (mod)
- (member (module-name mod)
- '((guile)
- (guile-user)
- (srfi srfi-1)
- )))
- (module-uses (resolve-module
- (cadr (car module-declaration-lst))))))
- (newline))
diff --git a/scripts/module-introspection.scm b/scripts/module-introspection.scm
deleted file mode 100644
index dc430d8a..00000000
--- a/scripts/module-introspection.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-(define-module (module-introspection)
- :use-module (srfi srfi-1)
- :use-module (hnh util)
- :export (get-forms
- uniq
- unique-symbols
- find-module-declaration
- module-declaration?
- ))
-
-
-(define (get-forms port)
- (let loop ((done '()))
- (let ((form (read port)))
- (if (eof-object? form)
- done
- (loop (cons form done))))))
-
-
-(define (uniq lst)
- (cond ((null? lst) lst)
- ((null? (cdr lst)) lst)
- ((and (pair? lst)
- (eqv? (car lst) (cadr lst)))
- (uniq (cons (car lst) (cddr lst))))
- (else (cons (car lst)
- (uniq (cdr lst))))))
-
-
-(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/set-version b/scripts/set-version
index 6f9d694c..fef13e90 100755
--- a/scripts/set-version
+++ b/scripts/set-version
@@ -6,4 +6,4 @@ fi
VERSION=$1
sed -i "s/^pkgver=.*/pkgver=$VERSION/" system/PKGBUILD
-sed -i "s/^(define-public version.*/(define-public version \"$VERSION\")/" module/calp.scm
+sed -i "s/^(define version.*/(define version \"$VERSION\")/" module/calp.scm
diff --git a/scripts/use2dot-all.sh b/scripts/use2dot-all.sh
new file mode 100755
index 00000000..80703d33
--- /dev/null
+++ b/scripts/use2dot-all.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+guild use2dot-all \
+ --engine fdp \
+ --output graph.pdf \
+ --default-module '(calp main)' \
+ --remove '((datetime) (vcomponent) (hnh util))' \
+ module
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/scripts/use2dot/graphviz.scm b/scripts/use2dot/graphviz.scm
deleted file mode 100644
index 9355d723..00000000
--- a/scripts/use2dot/graphviz.scm
+++ /dev/null
@@ -1,84 +0,0 @@
-;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
-;;;
-;;; This program is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; https://github.com/roelj/graphviz-guile/blob/master/graphviz.scm
-
-(define-module (graphviz)
- :export (;; New graphs
- graph
- digraph
- strictgraph
- strictdigraph
- readstring
- read
-
- ;; New nodes/edges
- node
- edge
-
- ;; Setting/getting attribute values
- setv
- getv
-
- ;; Finding and obtaining names
- nameof
- findsubg
- findnode
- findedge
- findattr
-
- ;; Graph navigators
- headof
- tailof
- graphof
- rootof
-
- ;; Obtain handles of proto node/edge for setting attribute values
- protonode
- protoedge
-
- ;; Iterators
- ok
- firstsubg
- nextsubg
- firstsupg
- nextsupg
- firstedge
- nextedge
- firstout
- nextout
- firsthead
- nexthead
- firstin
- nextin
- firstnode
- nextnode
- firstattr
- nextattr
-
- ;; Remove graph objects
- rm
-
- ;; Layout
- layout
- render
- renderresult
- renderchannel
- renderdata
- write))
-
-;; (load-extension "libgv_guile.so" "SWIG_init")
-
-(load-extension "/usr/lib/graphviz/guile/libgv_guile.so" "SWIG_init")
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-11 11:26:23 +0200