scheme-requests-for-implementation · arthurgleckler · Oct 13, 2022 · Oct 13, 2022 · Oct 13, 2022 · Oct 13, 2022
diff --git a/srfi-tools/asciidoc.sld b/srfi-tools/asciidoc.sld
@@ -0,0 +1,74 @@
+(define-library (srfi-tools asciidoc)
+  (export srfi-from-asciidoc)
+  (import (scheme base)
+          (scheme char)
+          (scheme cxr)
+          (scheme file)
+          (scheme write)
+          (srfi-tools private list)
+          (srfi-tools private string)
+          (srfi-tools private command)
+          (srfi-tools private port)
+          (srfi-tools private os)
+          (srfi-tools private sxml)
+          (srfi-tools private html-parser)
+          (srfi-tools private html-writer))
+  (begin
+
+    (define (sxml-cleanup elem)
+      (let-values (((name attrs body) (parse-tag elem)))
+        (case name
+          ((#f)
+           elem)
+          ((head)
+           (make-tag name #f
+                     (map sxml-cleanup
+                          (remove-subtags
+                           (flatten-subtags body 'meta)
+                           'meta 'link 'style))))
+          (else
+           (make-tag name
+                     (and attrs
+                          (filter (lambda (attr) (eqv? 'href (car attr)))
+                                  attrs))
+                     (map sxml-cleanup (remove-subtags
+                                        (flatten-subtags
+                                         (remove-subtag-ids body "footer")
+                                         'div)
+                                        'div
+                                        'colgroup)))))))
+
+    (define (srfi-from-asciidoc asciidoc-file)
+      (unless (string-suffix? ".adoc" asciidoc-file)
+        (error "Input file name extension is not .adoc"))
+      (let ((html-file (string-append
+                        (substring asciidoc-file 0
+                                   (- (string-length asciidoc-file)
+                                      (string-length ".adoc")))
+                        ".html")))
+        (for-each display (list "Converting " asciidoc-file " to " html-file))
+        (newline)
+        (let ((asciidoc (with-input-from-file asciidoc-file read-all-chars)))
+          (let ((html (run-program/get-output-string
+                       (list "asciidoctor"
+                             "-b" "xhtml5"
+                             "-o" "-"
+                             "--"
+                             asciidoc-file))))
+            (let ((sxml (html->sxml (open-input-string html))))
+              (set! sxml (sxml-cleanup (find-html-tag sxml)))
+              (set! html (with-output-to-string
+                           (lambda ()
+                             (write-string "<!doctype html>")
+                             (sxml-display-as-html sxml))))
+              ;; (set! html (run-pipe html "tidy" "-q" "--tidy-mark" "no" "-indent"))
+              (call-with-output-file html-file
+                (lambda (out) (write-string html out))))))))
+
+    ;; This converts a SRFI written in AsciiDoc into HTML. (Note that
+    ;; HTML is the required submittion format.) This command is useful
+    ;; for the initial conversion, but afterwards it's easier for all
+    ;; concerned to edit the HTML and throw away the original AsciiDoc
+    ;; sources.
+    (define-command (from-asciidoc asciidoc-file)
+      (srfi-from-asciidoc asciidoc-file))))
diff --git a/srfi-tools/github.sld b/srfi-tools/github.sld
@@ -1,6 +1,7 @@
 (define-library (srfi-tools github)
   (export srfi-github-org
           srfi-github-authorization-token
+          srfi-github-url
           srfi-github-https-url
           srfi-github-ssh-url
           srfi-create-github-repository)
@@ -32,6 +33,15 @@
     (define (srfi-github-relative-git num)
       (string-append (srfi-github-relative num) ".git"))
 
+    (define (srfi-github-url num)
+      (string-append "https://github.com/"
+                     (srfi-github-relative num)))
+
+    (define-command (github-url num)
+      (write-line-about-srfi srfi-github-url num))
+
+    ;; Is this superfluous? `srfi-github-url` can fetch both the repo
+    ;; and the web page.
     (define (srfi-github-https-url num)
       (string-append "https://github.com/"
                      (srfi-github-relative-git num)))

diff --git a/srfi-tools/interactive.sld b/srfi-tools/interactive.sld
@@ -6,6 +6,7 @@
           srfi-browse-url
           srfi-browse-landing
           srfi-browse-landing-url
+          srfi-browse-github-url
           srfi-pager
           srfi-edit
           srfi-browse-mail-archive-url)
@@ -17,7 +18,8 @@
           (srfi-tools path)
           (srfi-tools html)
           (srfi-tools mail)
-          (srfi-tools url))
+          (srfi-tools url)
+          (srfi-tools github))
   (begin
 
     (define (srfi-open-dir num)
@@ -72,6 +74,12 @@
     (define-command (browse-landing-url num)
       (srfi-browse-landing-url (parse-srfi-number num)))
 
+    (define (srfi-browse-github-url num)
+      (browse-url (srfi-github-url num)))
+
+    (define-command (browse-github-url num)
+      (srfi-browse-github-url (parse-srfi-number num)))
+
     ;;
 
     (define (srfi-pager num)

diff --git a/srfi-tools/main.sld b/srfi-tools/main.sld
@@ -7,7 +7,8 @@
           (srfi-tools private port)
           (srfi-tools private error)
           (srfi-tools private command))
-  (import (srfi-tools data)
+  (import (srfi-tools asciidoc)
+          (srfi-tools data)
           (srfi-tools count)
           (srfi-tools generate)
           (srfi-tools git)

diff --git a/srfi-tools/private/list.sld b/srfi-tools/private/list.sld
@@ -2,6 +2,7 @@
   (export any
           append-map
           append-reverse
+          cons*
           drop
           drop-right
           take
@@ -23,7 +24,7 @@
 
   (import (scheme base)
           (only (srfi 1)
-                any append-map append-reverse drop drop-right
+                any append-map append-reverse cons* drop drop-right
                 take take-right
                 first second third
                 filter filter-map find fold remove last))

diff --git a/srfi-tools/private/sxml.sld b/srfi-tools/private/sxml.sld
@@ -2,7 +2,14 @@
   (export sxml-for-each
           sxml-attributes
           sxml-body
-          sxml-body-as-string)
+          sxml-body-as-string
+          find-html-tag
+          tag-with-attrs?
+          parse-tag
+          make-tag
+          remove-subtags
+          remove-subtag-ids
+          flatten-subtags)
   (import (scheme base)
           (scheme cxr)
           (srfi-tools private list))
@@ -43,4 +50,63 @@
                      (else
                       (error "Unrecognized SXML" part)))))
             ""
-            (sxml-body elem)))))
+            (sxml-body elem)))
+
+    ;;
+
+    (define (find-html-tag sxml)
+      (and (pair? sxml)
+           (or (and (pair? (car sxml))
+                    (eqv? 'html (caar sxml))
+                    (car sxml))
+               (find-html-tag (cdr sxml)))))
+
+    (define (tag-with-attrs? elem)
+      (and (pair? (cdr elem))
+           (pair? (cadr elem))
+           (eqv? '@ (caadr elem))))
+
+    (define (parse-tag elem)
+      (if (or (not (pair? elem))
+              (not (symbol? (car elem)))
+              (eqv? '@ (car elem)))
+          (values #f #f #f)
+          (let ((name (car elem)))
+            (set! elem (cdr elem))
+            (let ((attrs (and (pair? elem)
+                              (pair? (car elem))
+                              (eqv? '@ (caar elem))
+                              (cdar elem))))
+              (when attrs (set! elem (cdr elem)))
+              (let ((body elem))
+                (values name attrs body))))))
+
+    (define (make-tag name attrs body)
+      (if (and attrs (not (null? attrs)))
+          (cons* name (cons '@ attrs) body)
+          (cons name body)))
+
+    (define (remove-subtags body . tag-names)
+      (filter (lambda (elem)
+                (let-values (((name attrs body) (parse-tag elem)))
+                  (not (and name (member name tag-names)))))
+              body))
+
+    (define (remove-subtag-ids body . ids)
+      (filter (lambda (elem)
+                (let-values (((name attrs body) (parse-tag elem)))
+                  (not (and attrs (let* ((pair (assoc 'id attrs))
+                                         (value (and pair (cadr pair))))
+                                    (and value (member value ids)))))))
+              body))
+
+    (define (flatten-subtags body . tag-names)
+      (let loop ((oldbody body) (newbody '()))
+        (if (null? oldbody)
+            newbody
+            (let-values (((name attrs elembody) (parse-tag (car oldbody))))
+              (if (and name (member name tag-names))
+                  (loop (append elembody (cdr oldbody))
+                        (append newbody (list (make-tag name attrs '()))))
+                  (loop (cdr oldbody)
+                        (append newbody (list (car oldbody)))))))))))
diff --git a/srfi-tools/private/sysdep.chibi.scm b/srfi-tools/private/sysdep.chibi.scm
@@ -5,14 +5,12 @@
         (prefix (chibi filesystem) chibi:)
         (prefix (chibi io) chibi:)
         (prefix (chibi process) chibi:)
-        (only (chibi io) port-fileno)  ; TODO: Bug workaround.
+        (prefix (only (chibi) port-fileno) chibi:)
         (srfi-tools private list)
         (srfi-tools private port))
 
 (begin
 
-  (define chibi:port-fileno port-fileno)  ; TODO: Bug workaround.
-
   (define (rename-file oldpath newpath)
     (chibi:rename-file oldpath newpath))