From e476387157e8e8fa45237a0736849c6452664234 Mon Sep 17 00:00:00 2001
From: Lassi Kortela <lassi@lassi.io>
Date: Wed, 5 Aug 2020 10:03:43 +0300
Subject: [PATCH] Add web page generator

---
 .gitignore   |  1 +
 generate.scm | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 70 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 generate.scm

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..2d19fc7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+*.html
diff --git a/generate.scm b/generate.scm
new file mode 100644
index 0000000..58bd243
--- /dev/null
+++ b/generate.scm
@@ -0,0 +1,69 @@
+(import (scheme base) (scheme file) (scheme read) (scheme write))
+
+(define (read-all)
+  (let loop ((xs '()))
+    (let ((x (read)))
+      (if (eof-object? x) (reverse xs) (loop (cons x xs))))))
+
+(define (group head xs)
+  (define (eject gs g) (if (null? g) gs (cons (reverse g) gs)))
+  (let loop ((xs xs) (gs '()) (g '()))
+    (cond ((null? xs)
+           (reverse (eject gs g)))
+          ((and (pair? (car xs)) (equal? head (caar xs)))
+           (loop (cdr xs) (eject gs g) (list (car xs))))
+          (else
+           (loop (cdr xs) gs (cons (car xs) g))))))
+
+(define (assoc1 key alist)
+  (let ((x (assoc key alist)))
+    (if (and (list? x) (= 2 (length x))) (cadr x) (error "Nope"))))
+
+(define (display-sxml x)
+  (define (display* . xs) (for-each display xs))
+  (define (display-attribute attribute)
+    (display* " " (car attribute) "=" "\"" (cdr attribute) "\""))
+  (cond ((pair? x)
+         (display* "<" (car x))
+         (let ((body (cond ((and (pair? (cdr x))
+                                 (pair? (cadr x))
+                                 (eq? '@ (car (cadr x))))
+                            (for-each display-attribute (cdr (cadr x)))
+                            (cddr x))
+                           (else (cdr x)))))
+           (display ">")
+           (for-each display-sxml body)
+           (display* "</" (car x) ">")))
+        ((string? x)
+         (display x))
+        (else (error "Bad"))))
+
+;;
+
+(define (scheme-id)
+  `((h2 "Scheme ID")
+    (table
+     (tr
+      (th "ID")
+      (th "Title")
+      (th "Contact"))
+     ,@(map (lambda (entry)
+              `(tr (td (code ,(symbol->string (assoc1 'id entry))))
+                   (td ,(assoc1 'title entry))
+                   (td ,(assoc1 'contact entry))))
+            (group 'id (with-input-from-file "scheme-id.scm" read-all))))))
+
+(define (display-page)
+  (display-sxml
+   `(html
+     (head
+      (title "Scheme registry")
+      (style "body { font-family: sans-serif; }"
+        "table, th, td { border: 1px solid black; }"
+        "table { border-collapse: collapse; }"))
+     (body
+      (h1 "Scheme registry")
+      (p "The Scheme registry collects identifiers.")
+      ,@(scheme-id)))))
+
+(with-output-to-file "index.html" display-page)