diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/all-modules.scm | 33 | ||||
| -rwxr-xr-x | scripts/fetch-liu-map-index.scm | 53 | ||||
| -rwxr-xr-x | scripts/module-dependants.scm | 4 | ||||
| -rwxr-xr-x | scripts/use2dot/gen-use.scm | 36 |
4 files changed, 94 insertions, 32 deletions
diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm new file mode 100644 index 00000000..41f35393 --- /dev/null +++ b/scripts/all-modules.scm @@ -0,0 +1,33 @@ +(define-module (all-modules) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (ice-9 ftw) + :use-module (ice-9 match) + :export (all-modules-under-directory)) + +(define (all-modules-under-directory dir) + "Returns two values, all scm files in dir, and all top +level modules in those files" + + (define re (make-regexp "\\.scm$")) + + (define files '()) + + (ftw dir (lambda (filename statinfo flag) + (cond ((and (eq? flag 'regular) + (regexp-exec re filename)) + => (lambda (m) + (set! files (cons filename files)) + #t + )) + (else #t)))) + + + (values files + (filter identity + (map (lambda (file) + (match (call-with-input-file file read) + (('define-module (module ...) _ ...) + module) + (_ #f))) + files)))) diff --git a/scripts/fetch-liu-map-index.scm b/scripts/fetch-liu-map-index.scm new file mode 100755 index 00000000..eea2a63d --- /dev/null +++ b/scripts/fetch-liu-map-index.scm @@ -0,0 +1,53 @@ +#!/usr/bin/guile \ +-s +!# + +;;; Commentary: +;; Bulids an index of "all" locations at LiU, and prints it as a JSON +;; object on the form { "location name": "url-fragment", ... }. These +;; fragments should be appended to the base "https://old.liu.se/karta/". +;; +;; See static/user/user-additions.js for this script in action. +;;; Code: + +(use-modules (srfi srfi-1) + (web client) + (web response) + (ice-9 rdelim) + (ice-9 format) + (sxml gumbo) + (sxml match) + (json)) + +(define-values (response body) (http-get "https://old.liu.se/karta/list?l=sv")) + +(unless (= 200 (response-code response)) + (format #t "Fetching index failed with ~a ~a~%" + (response-code response) + (response-reason-phrase response)) + (format #t "~{~s~%~}" (response-headers response)) + (exit 1)) + +(define data (html->sxml body)) + +(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) + +(scm->json (hash-map->list (lambda (name frag) + `(,name . ,frag)) + link-table)) +(newline) diff --git a/scripts/module-dependants.scm b/scripts/module-dependants.scm index 212a28c8..95e5bf53 100755 --- a/scripts/module-dependants.scm +++ b/scripts/module-dependants.scm @@ -49,7 +49,7 @@ (define (regular-file? filename) (eq? 'regular (stat:type (cstat filename)))) -(define (filename-extension ext) +(define (filename-extension? ext) (let ((re (make-regexp (string-append ((@ (texinfo string-utils) escape-special-chars) ext "^$[]()*." #\\) @@ -88,7 +88,7 @@ ))) ) (delete target-file - (filter (filename-extension ".scm") + (filter (filename-extension? ".scm") (filter regular-file? (find-all-files-under module-dir))))))) diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm index 02785088..6c621fdd 100755 --- a/scripts/use2dot/gen-use.scm +++ b/scripts/use2dot/gen-use.scm @@ -2,43 +2,19 @@ !# (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) - (ice-9 ftw) - (ice-9 regex) - (ice-9 match) ((graphviz) :prefix gv.) + (all-modules) ) (define scan (make-frisker `(default-module . (calp main)))) -(define re (make-regexp "\\.scm$")) - -(define lst '()) - -(ftw "module" (lambda (filename statinfo flag) - (cond ((and (eq? flag 'regular) - (regexp-exec re filename)) - => (lambda (m) - (set! lst (cons filename lst)) - #t - )) - (else #t)))) - - - -(define files lst) - -(define our-modules - (filter identity - (map (lambda (file) - (match (call-with-input-file file read) - (('define-module (module ...) _ ...) - module) - (_ #f))) - files))) +(define-values (files our-modules) + (all-modules-under-directory "module")) (define graph (gv.digraph "G")) (gv.setv graph "color" "blue") @@ -133,7 +109,7 @@ (for-each (lambda (edge) - (let ((gv-edge (gv.edge graph + (let ((gv-edge (gv.edge graph (format #f "~a" (edge-down edge)) (format #f "~a" (edge-up edge)) ))) @@ -144,7 +120,7 @@ (not (memv (car (edge-down edge)) '(vcomponent calp )))) (gv.setv gv-edge "color" "blue")) )) - (remove-edges '((srfi srfi-1) + (remove-edges '((srfi srfi-1) (srfi srfi-9) (srfi srfi-26) (srfi srfi-41) |