More srfi-tools patches

srfi-tools/.gitignore

@@ -5,3 +5,4 @@
 *.o
 *.so
 .akku
+local.sld

srfi-tools/count.sld

@@ -22,11 +22,7 @@
                  (count year)))))))))
 
     (define-command (count-by-year)
-      (for-each (lambda (pair)
-                  (let ((year (car pair))
-                        (count (cdr pair)))
-                    (disp year "  " count)))
-                (srfi-count-by-year)))
+      (display-two-column-table (srfi-count-by-year)))
 
     (define (srfi-count-by-author)
       (list-sort
@@ -39,8 +35,4 @@
                        (srfi-authors srfi))))))))
 
     (define-command (count-by-author)
-      (for-each (lambda (pair)
-                  (let ((name (car pair))
-                        (count (cdr pair)))
-                    (disp count "  " name)))
-                (srfi-count-by-author)))))
+      (display-two-column-table (srfi-count-by-author)))))

srfi-tools/html.sld

@@ -11,11 +11,15 @@
           srfi-link-md)
   (import (scheme base)
           (scheme file)
+          (srfi-tools private list)
+          (srfi-tools private string)
+          (srfi-tools private hash-table)
           (srfi-tools private file)
           (srfi-tools private format)
           (srfi-tools private port)
           (srfi-tools private external)
           (srfi-tools private command)
+          (srfi-tools private sxml)
           (srfi-tools private html-parser)
           (srfi-tools private html-writer)
           (srfi-tools data)
@@ -81,4 +85,35 @@
               (srfi-html-url num)))
 
     (define-command (link-md num)
-      (disp (srfi-link-md (parse-srfi-number num))))))
+      (disp (srfi-link-md (parse-srfi-number num))))
+
+    (define (tag-names-fold elem merge state)
+      (let do-elem ((elem elem) (state state))
+        (if (not (pair? elem))
+            state
+            (let do-list ((elems (sxml-body elem))
+                          (state (merge (car elem) state)))
+              (if (null? elems)
+                  state
+                  (do-list (cdr elems)
+                           (do-elem (car elems) state)))))))
+
+    (define (srfi-count-html-tags nums)
+      (list-sort
+       (reverse-pair<? string<? >)
+       (tally
+        (lambda (count)
+          (for-each
+           (lambda (num)
+             (tag-names-fold
+              (srfi-sxml num)
+              (lambda (tag _)
+                (let ((tag (symbol->string tag)))
+                  (unless (string-prefix? "*" tag)
+                    (count tag))))
+              #f))
+           nums)))))
+
+    (define-command (count-html-tags num)
+      (display-two-column-table
+       (srfi-count-html-tags (list (parse-srfi-number num)))))))

srfi-tools/library.sld

@@ -0,0 +1,56 @@
+(define-library (srfi-tools library)
+  (export srfi-library-names-sxml
+          srfi-write-library-names)
+  (import (scheme base)
+          (scheme file)
+          (srfi-tools private list)
+          (srfi-tools private format)
+          (srfi-tools private path)
+          (srfi-tools private port)
+          (srfi-tools private html-writer)
+          (srfi-tools private command)
+          (srfi-tools data)
+          (srfi-tools path)
+          (srfi-tools url))
+  (begin
+
+    (define (srfi-library-names-sxml)
+      (let ((title "SRFI library names"))
+        `(html
+          (head
+           (title ,title)
+           (style "table, th, td { border: 1px solid black; }"))
+          (body
+           (h1 ,title)
+           (p "The initial batch of library names was coined in "
+              (a (@ (href ,(srfi-landing-url 97)))
+                 "SRFI 97") ". "
+                 "The up to date list is kept in "
+                 (code "srfi-data.scm"))
+           (table
+            (tr (th "")
+                (th "R6RS")
+                (th "R7RS"))
+            ,@(filter-map
+               (lambda (srfi)
+                 (let ((num (srfi-number srfi))
+                       (name (srfi-library-name srfi)))
+                   (and name
+                        `(tr (td (a (@ (href ,(srfi-landing-url num))
+                                       (title ,(srfi-title srfi)))
+                                    "SRFI " ,(number->string num)))
+                             (td (code ,(format "(import (srfi :~a ~a))"
+                                                num name)))
+                             (td (code ,(format "(import (srfi ~a))"
+                                                num)))))))
+               (srfi-list)))))))
+
+    (define (srfi-write-library-names)
+      (let ((file (path-append (srfi-common-dir) "library-names.html"))
+            (sxml (srfi-library-names-sxml)))
+        (disp "Writing " file)
+        (with-output-to-file file
+          (lambda () (sxml-display-as-html sxml)))))
+
+    (define-command (write-library-names)
+      (srfi-write-library-names))))

srfi-tools/local.example.sld

@@ -3,25 +3,23 @@
           (srfi-tools private command)
           (srfi-tools private external)
           (srfi-tools data)
+          (srfi-tools path)
           (srfi-tools interactive))
   (begin
 
-    (define-command (grep num text)
-      (srfi-run num (list "grep" text)))
-
-    ;; Examples:
+    ;; You can define custom commans in this file. For example:
 
     (define-command (links num)
-      (browse-url-with "links" (srfi-html-url num)))
+      (browse-url-with "links" (srfi-html-file (parse-srfi-number num))))
 
     (define-command (lynx num)
-      (browse-url-with "lynx" (srfi-html-url num)))
+      (browse-url-with "lynx" (srfi-html-file (parse-srfi-number num))))
 
     (define-command (w3m num)
-      (browse-url-with "w3m" (srfi-html-url num)))
+      (browse-url-with "w3m" (srfi-html-file (parse-srfi-number num))))
 
     ;; Define what you want the shell command `srfi` to do.
-    (srfi-default-command 'list)
+    (srfi-default-command "list")
 
     ;; Define what you want the shell command `srfi 123` to do.
-    (srfi-default-number-command 'info)))
+    (srfi-default-number-command "info")))

srfi-tools/main.sld

@@ -15,6 +15,7 @@
           (srfi-tools html)
           (srfi-tools info)
           (srfi-tools interactive)
+          (srfi-tools library)
           (srfi-tools mail)
           (srfi-tools missing)
           (srfi-tools path)

srfi-tools/private/README.org

@@ -1,4 +1,10 @@
-Note that many of the files in this directories are snapshots of code
-from Chibi Scheme.
+The file chibi-sxml.scm is copied from
+https://github.com/ashinn/chibi-scheme
+file lib/chibi/sxml.scm
 
-https://github.com/ashinn/chibi-scheme
+The file chibi-html-parser.scm is copied from
+https://snow-fort.org/pkg library (chibi html-parser)
+file html-parser.scm.
+
+The file format.sld is adapted from the sample implementation of
+SRFI 28.

srfi-tools/private/list.sld

@@ -4,8 +4,11 @@
           append-reverse
           drop
           drop-right
+          take
+          take-right
           first second third
           filter
+          filter-map
           find
           fold
           remove
@@ -21,8 +24,9 @@
   (import (scheme base)
           (only (srfi 1)
                 any append-map append-reverse drop drop-right
+                take take-right
                 first second third
-                filter find fold remove last))
+                filter filter-map find fold remove last))
 
   (cond-expand
    ((or chibi cyclone gauche sagittarius)

srfi-tools/private/port.sld

@@ -7,11 +7,13 @@
           displayed
           disp
           edisp
+          display-two-column-table
           copy-binary-port)
   (import (scheme base)
           (scheme file)
           (scheme read)
           (scheme write)
+          (srfi-tools private list)
           (srfi-tools private string))
   (begin
 
@@ -58,6 +60,19 @@
           (apply disp args))
         (flush-output-port (current-error-port))))
 
+    (define (display-two-column-table alist)
+      (let* ((cars (map displayed (map car alist)))
+             (cdrs (map displayed (map cdr alist)))
+             (width (fold max 0 (map string-length cars))))
+        (for-each (lambda (car cdr)
+                    (let ((padding (- width (string-length car))))
+                      (write-string car)
+                      (write-string (make-string (+ padding 2) #\space))
+                      (write-string cdr)
+                      (newline)))
+                  cars
+                  cdrs)))
+
     (define (copy-binary-port input-port output-port)
       (let ((buffer (make-bytevector (* 100 1024))))
         (let loop ()

srfi-tools/srfi-db.scm

@@ -198,9 +198,12 @@
                  (srfi/authors
                   (srfi-by-number (parse-srfi-number num))))))
 
-(define (srfi-one-line-summary srfi)
+(define (srfi-format-number-and-title srfi)
   (string-append "SRFI " (number->string (srfi-number srfi)) ": "
-                 (srfi-title srfi)
+                 (srfi-title srfi)))
+
+(define (srfi-one-line-summary srfi)
+  (string-append (srfi-format-number-and-title srfi)
                  " ("
                  (case (srfi-status srfi)
                    ((final)
@@ -229,11 +232,17 @@
 (define-command (list)
   (write-srfi-list (srfi-list)))
 
+(define (srfi-tail)
+  (take-right (all-srfis) 10))
+
+(define-command (tail)
+  (write-srfi-list (srfi-tail)))
+
 (define (srfi-drafts)
   (filter srfi-draft? (all-srfis)))
 
 (define-command (drafts)
-  (write-srfi-list (srfi-drafts)))
+  (for-each write-line (map srfi-format-number-and-title (srfi-drafts))))
 
 (define (srfi-by-author name)
   (filter (lambda (srfi)

srfi-tools/srfi-tools.egg

@@ -11,7 +11,7 @@
  (distribution-files
   "private/chibi-html-parser.scm" "private/chibi-sxml.scm" "core.sld"
   "count.sld" "data.sld" "git.sld" "github.sld" "help.sld" "html.sld"
-  "info.sld" "interactive.sld" "mail.sld" "main.sld"
+  "info.sld" "interactive.sld" "library.sld" "mail.sld" "main.sld"
   "missing.sld" "path.sld" "pre.sld" "private/command.sld" "private/error.sld"
   "private/external.sld" "private/file.sld" "private/format.sld"
   "private/hash-table.sld" "private/html-parser.sld" "private/html-writer.sld"
@@ -100,6 +100,15 @@
     srfi-tools.path srfi-tools.private.command srfi-tools.private.external
     srfi-tools.private.os srfi-tools.url)
    (csc-options "-R" "r7rs" "-X" "r7rs"))
+  (extension
+   srfi-tools.library
+   (source "library.sld")
+   (component-dependencies
+    srfi-tools.data srfi-tools.path
+    srfi-tools.private.command srfi-tools.private.html-writer
+    srfi-tools.private.list srfi-tools.private.path srfi-tools.private.port
+    srfi-tools.url)
+   (csc-options "-R" "r7rs" "-X" "r7rs"))
   (extension
    srfi-tools.mail
    (source "mail.sld")