From 1f398c64eacff764aba2dac1611b81951007997f Mon Sep 17 00:00:00 2001
From: Lassi Kortela <lassi@lassi.io>
Date: Fri, 2 Dec 2022 00:09:54 +0200
Subject: [PATCH] Initial commit

---
 .gitignore               |   1 +
 data/index.pose          |  46 ++++++++
 scripts/generate-docs.sh |  13 +++
 scripts/generate.scm     | 244 +++++++++++++++++++++++++++++++++++++++
 scripts/upload.sh        |   7 ++
 www/review.css           |  22 ++++
 6 files changed, 333 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 data/index.pose
 create mode 100755 scripts/generate-docs.sh
 create mode 100755 scripts/generate.scm
 create mode 100755 scripts/upload.sh
 create mode 100644 www/review.css

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..2d19fc7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+*.html
diff --git a/data/index.pose b/data/index.pose
new file mode 100644
index 0000000..abf605f
--- /dev/null
+++ b/data/index.pose
@@ -0,0 +1,46 @@
+(file (role data))
+
+(tag
+ (id "convenience")
+ (title "Convenience"))
+
+(tag
+ (id "libraries")
+ (title "Libraries"))
+
+(tag
+ (id "process")
+ (title "Process"))
+
+(tag
+ (id "strings")
+ (title "Strings"))
+
+(tag
+ (id "symbols")
+ (title "Symbols"))
+
+(proposal
+ (year 2022)
+ (ordinal 1)
+ (status draft)
+ (title "Scheme Review")
+ (author "Lassi Kortela")
+ (tag "process")
+ (draft
+  (number 1)
+  (date "2022-12-01 ")))
+
+(proposal
+ (year 2022)
+ (ordinal 2)
+ (status draft)
+ (title "Symbols as strings")
+ (author "Lassi Kortela")
+ (tag "libraries")
+ (tag "convenience")
+ (tag "symbols")
+ (tag "strings")
+ (draft
+  (number 1)
+  (date "2022-12-01 ")))
diff --git a/scripts/generate-docs.sh b/scripts/generate-docs.sh
new file mode 100755
index 0000000..f511bed
--- /dev/null
+++ b/scripts/generate-docs.sh
@@ -0,0 +1,13 @@
+#!/bin/sh
+set -eu
+cd "$(dirname "$0")"/..
+echo "Entering directory '$PWD'"
+root=../../scheme-review
+for proposal in $(cd "$root" && ls -d 20*-*); do
+    source="$root/$proposal/document.md"
+    target="www/$proposal.html"
+    if test -f "$source"; then
+        echo "Writing $target"
+        pandoc -o "$target" "$source"
+    fi
+done
diff --git a/scripts/generate.scm b/scripts/generate.scm
new file mode 100755
index 0000000..5a8a48d
--- /dev/null
+++ b/scripts/generate.scm
@@ -0,0 +1,244 @@
+#! /usr/bin/env gosh
+
+(import (scheme base)
+        (scheme cxr)
+        (scheme file)
+        (scheme read)
+        (scheme write)
+        (srfi 1)
+        (srfi 193))
+
+(define root-directory
+  (string-append (script-directory) ".." "/"))
+
+(define (asset . parts)
+  (let loop ((path root-directory) (parts parts))
+    (cond ((null? parts)
+           path)
+          ((null? (cdr parts))
+           (string-append path (car parts)))
+          (else
+           (loop (string-append path (car parts) "/")
+                 (cdr parts))))))
+
+(define (positive-integer? obj)
+  (and (integer? obj)
+       (positive? obj)))
+
+(define (valid-year? obj)
+  (and (integer? obj)
+       (<= 1970 obj 2070)))
+
+(define (interpose delimiter list)
+  (if (null? list)
+      '()
+      (let loop ((new '()) (list list))
+        (if (null? (cdr list))
+            (reverse (cons (first list) new))
+            (loop (cons* delimiter (first list) new)
+                  (cdr list))))))
+
+(define-syntax define-enum
+  (syntax-rules ()
+    ((define-symbols enum symbol ...)
+     (begin (define symbol 'symbol)
+            ...
+            (define enum (list symbol ...))))))
+
+(define-enum statuses
+  draft
+  final
+  withdrawn
+  superseded
+  living)
+
+(define (valid-status? obj)
+  (not (not (member obj statuses))))
+
+(define (generator->list g)
+  (let loop ((xs '()))
+    (let ((x (g)))
+      (if (eof-object? x) (reverse xs) (loop (cons x xs))))))
+
+(define (read-all)
+  (generator->list read))
+
+(define (display-sxml x)
+  (define (display* . xs) (for-each display xs))
+  (define (display-char char)
+    (let* ((cc (char->integer char))
+           (ok? (case char ((#\& #\< #\> #\") #f) (else (<= #x20 cc #x7e)))))
+      (if ok? (display char) (display* "&#" cc ";"))))
+  (define (display-attribute attribute)
+    (display* " " (car attribute) "=\"")
+    (string-for-each display-char (cadr attribute))
+    (display "\""))
+  (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)
+           (unless (memq (car x) '(meta br))
+             (display* "</" (car x) ">"))))
+        ((string? x)
+         (string-for-each display-char x))
+        (else (error "Bad:" x))))
+
+(define (get-all alist key)
+  (let loop ((results '()) (alist alist))
+    (if (null? alist)
+        (reverse results)
+        (let ((entry (car alist)))
+          (cond ((not (and (pair? entry)
+                           (equal? key (car entry))))
+                 (loop results
+                       (cdr alist)))
+                (else
+                 (loop (cons entry results)
+                       (cdr alist))))))))
+
+(define (get-one alist key valid?)
+  (let ((all (get-all alist key)))
+    (cond ((= (length all) 0)
+           (error "No" key))
+          ((> (length all) 1)
+           (error "Multiple" key))
+          ((not (valid? (cadar all)))
+           (error "Not valid" (cadar all)))
+          (else
+           (cadar all)))))
+
+(define (one-getter key valid?)
+  (lambda (alist)
+    (get-one alist key valid?)))
+
+(define (all-getter key)
+  (lambda (alist)
+    (get-all alist key)))
+
+(define index
+  (with-input-from-file (asset "data" "index.pose")
+    read-all))
+
+(define (head=? key)
+  (lambda (form)
+    (and (pair? form)
+         (equal? key (car form)))))
+
+(define tag-entry-id (one-getter 'id string?))
+(define tag-entry-title (one-getter 'title string?))
+
+(define (all-tag-entries)
+  (filter (head=? 'tag) index))
+
+(define (tag-entry-by-id tag-id)
+  (find (lambda (entry)
+          (equal? tag-id (tag-entry-id entry)))
+        (all-tag-entries)))
+
+(define (all-tags)
+  (map tag-entry-id (all-tag-entries)))
+
+(define (tag-title tag-id)
+  (let ((entry (tag-entry-by-id tag-id)))
+    (if entry
+        (tag-entry-title entry)
+        (error "No such tag" tag-id))))
+
+(define draft-number (one-getter 'number positive-integer?))
+
+(define proposal-year (one-getter 'year valid-year?))
+(define proposal-ordinal (one-getter 'ordinal positive-integer?))
+(define proposal-status (one-getter 'status valid-status?))
+(define proposal-title (one-getter 'title string?))
+(define proposal-drafts (all-getter 'draft))
+
+(define (proposal-authors proposal)
+  (map second (get-all proposal 'author)))
+
+(define (proposal-tags proposal)
+  (map second (get-all proposal 'tag)))
+
+(define (proposals)
+  (filter (head=? 'proposal) index))
+
+(define (proposal-id proposal)
+  (string-append (number->string (proposal-year proposal))
+                 "-"
+                 (number->string (proposal-ordinal proposal))))
+
+(define (proposal-latest-draft-number proposal)
+  (apply max (map draft-number (proposal-drafts proposal))))
+
+(define (proposal-latest-uri proposal)
+  (string-append (proposal-id proposal)
+                 ".html"))
+
+(define (proposal-repository-uri proposal)
+  (string-append "https://gitea.scheme.org/review/"
+                 (proposal-id proposal)))
+
+(define (proposal-discussion-uri proposal)
+  (string-append (proposal-repository-uri proposal)
+                 "/issues"))
+
+(define title "Scheme Review")
+
+(define intro
+  `((p "Peer review for documents and code."
+       " SRFI without the constraints.")
+    (ul
+     (li "Draft-based."
+         " Send a new draft whenever you have"
+         " something people should read.")
+     (li "No deadlines."
+         " If it takes ten years to perfect your"
+         " proposal, that's fine.")
+     (li "Not limited to requests for implementation."
+         " Submit anything you want schemers to review -"
+         " whether a neat hack, an aesthetic note, a survey,"
+         " or a full fledged library."))))
+
+(define (main)
+  (with-output-to-file (asset "www" "index.html")
+    (lambda ()
+      (display-sxml
+       `(html
+         (head
+          (title ,title)
+          (link (@ (rel "stylesheet")
+                   (href "review.css"))))
+         (body
+          (h1 ,title)
+          (section
+           (@ (class "intro box"))
+           ,@intro)
+          (section
+           (ul
+            (@ (class "proposals"))
+            ,@(map (lambda (proposal)
+                     `(li (@ (class "proposal box"))
+                          (b ,(proposal-id proposal)
+                             ": "
+                             ,(proposal-title proposal))
+                          (br)
+                          (a (@ (href ,(proposal-latest-uri proposal)))
+                             "Document")
+                          " | "
+                          (a (@ (href ,(proposal-repository-uri proposal)))
+                             "Repo")
+                          " | "
+                          (a (@ (href ,(proposal-discussion-uri proposal)))
+                             "Talk")
+                          " | "
+                          "Tags: "
+                          ,@(interpose ", "
+                                       (map tag-title (proposal-tags proposal)))))
+                   (reverse (proposals)))))))))))
+
+(main)
diff --git a/scripts/upload.sh b/scripts/upload.sh
new file mode 100755
index 0000000..e720275
--- /dev/null
+++ b/scripts/upload.sh
@@ -0,0 +1,7 @@
+#!/bin/sh
+set -eu
+cd "$(dirname "$0")"/..
+set -x
+scripts/generate.scm
+scripts/generate-docs.sh
+rsync -vcr www/ alpha.servers.scheme.org:/production/groups/www/review/
diff --git a/www/review.css b/www/review.css
new file mode 100644
index 0000000..032f3d6
--- /dev/null
+++ b/www/review.css
@@ -0,0 +1,22 @@
+body {
+  font-family: sans-serif;
+}
+
+.box {
+  border-radius: 20px;
+  padding: 1em;
+  margin: 1em;
+  margin-left: 0;
+}
+
+.intro {
+  background-color: lightgreen;
+}
+
+ul.proposals {
+  padding-left: 0;
+}
+
+li.proposal {
+  background-color: wheat;
+}