Merge call-with-tmpfile and diffs for testrunner.

Merge branch 'next' into c-parser

8 files changed, 145 insertions, 48 deletions

diff --git a/doc/ref/javascript/formatters.texi b/doc/ref/javascript/formatters.texi
index 71394b39..a3086aa9 100644
--- a/doc/ref/javascript/formatters.texi
+++ b/doc/ref/javascript/formatters.texi
@@ -4,6 +4,12 @@
 Formatting procedures used by some components.
 @c TODO can we have a backref of every node containing @ref{formatters-proc}?
 
+@deftypefun void format(targetElement:HTMLElement, data:VEvent, key:string)
+Checks if a specific formatter exists for the given key, and executes
+it.
+Defaults to 'default', and also runs that if the regular formatter throws.
+@end deftypefun
+
 @deftypevar {Map<string, (e:HTMLElement, d:VEvent, s:any) => void>} formatters
 @anchor{formatters-proc}
 
diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm
index 6aed85ac..2fbad39f 100644
--- a/module/hnh/util/io.scm
+++ b/module/hnh/util/io.scm
@@ -5,6 +5,7 @@
            open-output-port
            read-lines
            with-atomic-output-to-file
+           call-with-tmpfile
            read-file))
 
 (define (open-input-port str)
@@ -64,6 +65,14 @@
         ;; value might as well return #f)
         #f))))
 
+(define* (call-with-tmpfile proc key: (tmpl "/tmp/file-XXXXXXX"))
+  (let* ((filename (string-copy tmpl))
+         (port (mkstemp! filename)))
+    (with-continuation-barrier
+     (lambda ()
+       (begin1
+        (proc port filename)
+        (close-port port))))))
 
 (define (read-file path)
   (call-with-input-file path read-string))
diff --git a/scripts/fetch-liu-map-index.scm b/scripts/fetch-liu-map-index.scm
index 31db3844..a9518c8d 100755
--- a/scripts/fetch-liu-map-index.scm
+++ b/scripts/fetch-liu-map-index.scm
@@ -19,35 +19,29 @@
              (ice-9 getopt-long)
              (sxml gumbo)
              (sxml match)
-             ((hnh util) :select (->))
+             ((sxml xpath) :select (sxpath))
+             ((hnh util) :select (-> ->>))
              (json))
 
 
 ;; 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 +79,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/peg-to-graph.scm b/scripts/peg-to-graph.scm
new file mode 100755
index 00000000..7edcd556
--- /dev/null
+++ b/scripts/peg-to-graph.scm
@@ -0,0 +1,56 @@
+#!/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 (get-forms unique-symbols))
+             (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/static/components/vevent-description.ts b/static/components/vevent-description.ts
index 463725f1..b44185e7 100644
--- a/static/components/vevent-description.ts
+++ b/static/components/vevent-description.ts
@@ -2,7 +2,7 @@ export { ComponentDescription }
 
 import { VEvent } from '../vevent'
 import { ComponentVEvent } from './vevent'
-import { formatters } from '../formatters'
+import { format } from '../formatters'
 
 /*
   <vevent-description />
@@ -23,14 +23,7 @@ class ComponentDescription extends ComponentVEvent {
 
         for (let el of body.querySelectorAll('[data-property]')) {
             if (!(el instanceof HTMLElement)) continue;
-            let p = el.dataset.property!;
-            let d;
-            if ((d = data.getProperty(p))) {
-                let key = p.toLowerCase();
-                let f = formatters.get(key);
-                if (f) f(el, data, d);
-                else window.formatters.get('default')!(el, data, d);
-            }
+            format(el, data, el.dataset.property!);
         }
 
         let repeating = body.getElementsByClassName('repeating')[0] as HTMLElement
diff --git a/static/formatters.ts b/static/formatters.ts
index 5605e051..e0018278 100644
--- a/static/formatters.ts
+++ b/static/formatters.ts
@@ -1,11 +1,11 @@
 export {
-    formatters,
+    format
 }
 
 import { makeElement } from './lib'
 import { VEvent } from './vevent'
 
-type formatter = (e: HTMLElement, d: VEvent, s: any) => void
+type formatter = (e: HTMLElement, d: VEvent, s: any) => Promise<void>
 
 declare global {
     interface Window {
@@ -16,8 +16,24 @@ declare global {
 let formatters: Map<string, formatter>;
 formatters = window.formatters = new Map();
 
+async function format(targetElement: HTMLElement, data: VEvent, key: string): Promise<void> {
+    let d = data.getProperty(key);
+    if (!d) return
+    let formatter = formatters.get(key.toLowerCase());
+    if (formatter) {
+        try {
+            await formatter(targetElement, data, d);
+        } catch (error) {
+            console.warn('Formatter failed')
+            console.warn(error);
+            formatters.get('default')!(targetElement, data, d);
+        }
+    } else {
+        formatters.get('default')!(targetElement, data, d);
+    }
+}
 
-formatters.set('categories', (el, _, d) => {
+formatters.set('categories', async (el, _, d) => {
     for (let item of d) {
         let q = encodeURIComponent(
             `(member "${item}" (or (prop event (quote CATEGORIES)) (quote ())))`)
@@ -28,7 +44,7 @@ formatters.set('categories', (el, _, d) => {
     }
 })
 
-function format_time_tag(el: HTMLElement, ev: VEvent, d: any): void {
+async function format_time_tag(el: HTMLElement, ev: VEvent, d: any): Promise<void> {
     if (el instanceof HTMLTimeElement) {
         if (d instanceof Date) {
             let fmt = '';
@@ -49,7 +65,7 @@ function format_time_tag(el: HTMLElement, ev: VEvent, d: any): void {
 formatters.set('dtstart', format_time_tag)
 formatters.set('dtend', format_time_tag)
 
-formatters.set('default', (el, _, d) => {
+formatters.set('default', async (el, _, d) => {
     let fmt;
     if ((fmt = el.dataset.fmt)) {
         el.textContent = d.format(fmt);
diff --git a/static/user/user-additions.js b/static/user/user-additions.js
index 7291f232..bfc0391d 100644
--- a/static/user/user-additions.js
+++ b/static/user/user-additions.js
@@ -1,4 +1,4 @@
-window.formatters.set('description', (el, ev, d) => {
+window.formatters.set('description', async (el, ev, d) => {
     if (ev.getProperty('X-MICROSOFT-SKYPETEAMSMEETINGURL')) {
         /* parse Microsoft Teams meeting entries */
         /* Replace lines with propper <hr> tags */
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index 7f7ccfcd..1f4a7bbe 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -22,12 +22,17 @@ fi
              (srfi srfi-64)
              (srfi srfi-88)
              (hnh util)
+             ((hnh util io) :select (call-with-tmpfile))
              (ice-9 ftw)
              (ice-9 format)
              (ice-9 pretty-print)
              (ice-9 getopt-long)
              (ice-9 match)
              (ice-9 regex)
+             ((ice-9 popen)
+              :select (open-pipe*
+                       close-pipe))
+             ((ice-9 rdelim) :select (read-string))
              (system vm coverage)
              ((all-modules) :select (fs-find))
              )
@@ -59,18 +64,29 @@ fi
   (string-replace s1 s2
                   0 (string-length s2)))
 
+(define (diff s1 s2)
+  (let ((filename1 (call-with-tmpfile (lambda (p f) (display s1 p) f)))
+        (filename2 (call-with-tmpfile (lambda (p f) (display s2 p) f))))
+    (let ((pipe (open-pipe*
+              OPEN_READ
+              ;; "git" "diff" "--no-index"
+              "diff"
+              filename1 filename2)))
+      (begin1 (begin
+                (read-string pipe))
+              (close-pipe pipe)))))
+
 (define (pp form indent prefix-1)
   (let ((prefix (make-string (+ (string-length indent)
                                 (string-length prefix-1))
                              #\space)))
-    (display
-     (string-replace-head
-      (with-output-to-string
-        (lambda () (pretty-print
-               form
-               per-line-prefix: prefix
-               width: (- 79 (string-length indent)))))
-      (string-append indent prefix-1)))))
+    (string-replace-head
+     (with-output-to-string
+       (lambda () (pretty-print
+              form
+              per-line-prefix: prefix
+              width: (- 79 (string-length indent)))))
+     (string-append indent prefix-1))))
 
 
 (define (construct-test-runner)
@@ -129,8 +145,15 @@ fi
                      (if (eq? expected unknown-expected)
                          (format #t "~aAssertion failed~%" indent)
                          (begin
-                           (pp expected indent "Expected: ")
-                           (pp actual indent "Received: "))))))))
+                           (display (pp expected indent "Expected: "))
+                           (display (pp actual indent "Received: "))
+                           (let ((d (diff (pp expected "" "")
+                                          (pp actual "" ""))))
+                             (display
+                              (string-join
+                               (map (lambda (line) (string-append indent "|" line))
+                                    (string-split d #\newline))
+                               "\n" 'suffix))))))))))
         (format #t "~aNear ~a:~a~%"
                 (make-indent (1+ depth))
                 (test-result-ref runner 'source-file)