More SRFI tool patches

srfi-tools/chart.scm

@@ -48,13 +48,13 @@
 		   (number->string (date-year today))
 		   (string-copy/cursors original end))))
 
-(define (chart-srfis today)
+(define (srfi-generate-chart today)
   (with-output-to-file "/tmp/srfi.gnuplot"
     (lambda () (write-string (gnuplot-commands today))))
   (write-srfi-data today)
   (run-program '("gnuplot" "/tmp/srfi.gnuplot"))
   (run-program `("cp" "-p" "/tmp/srfi.svg" ,(srfi-common-dir))))
 
-(define-command (chart)
+(define-command (generate-chart)
   "Generate the SRFI progress chart as an SVG file."
-  (chart-srfis (current-date)))
+  (srfi-generate-chart (current-date)))

srfi-tools/chart.sld

@@ -1,5 +1,5 @@
 (define-library (srfi-tools chart)
-  (export chart-srfis)
+  (export srfi-generate-chart)
   (import (scheme base)
 	  (scheme file)
 	  (scheme write)

srfi-tools/data.sld

@@ -51,15 +51,15 @@
           (scheme cxr)
           (scheme file)
           (scheme read)
-          (srfi-tools assert)
+          (srfi-tools private error)
 	  (srfi-tools private list)
           (srfi-tools private string)
           (srfi-tools private port)
           (srfi-tools private file)
           (srfi-tools private command)
           (srfi-tools core)
           (srfi-tools path))
-  (include "srfi-db.scm")
+  (include "data.scm")
   (cond-expand
    (mit
     (begin

srfi-tools/legal.sld

@@ -0,0 +1,40 @@
+(define-library (srfi-tools legal)
+  (import (scheme base)
+          (srfi-tools private string)
+          (srfi-tools private command))
+  (export srfi-license-lines
+          srfi-license-string)
+  (begin
+
+    (define mit-license-boilerplate
+      '(""
+        "Permission is hereby granted, free of charge, to any person obtaining"
+        "a copy of this software and associated documentation files (the"
+        "\"Software\"), to deal in the Software without restriction, including"
+        "without limitation the rights to use, copy, modify, merge, publish,"
+        "distribute, sublicense, and/or sell copies of the Software, and to"
+        "permit persons to whom the Software is furnished to do so, subject to"
+        "the following conditions:"
+        ""
+        "The above copyright notice and this permission notice shall be"
+        "included in all copies or substantial portions of the Software."
+        ""
+        "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,"
+        "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF"
+        "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND"
+        "NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE"
+        "LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION"
+        "OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION"
+        "WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE."))
+
+    (define (srfi-license-lines who)
+      (append (list (string-append "Copyright (C) " who "."))
+              mit-license-boilerplate))
+
+    (define (srfi-license-string who)
+      (string-join (append (srfi-license-lines who) (list ""))
+                   "\n"))
+
+    (define-command (generate-license who)
+      "Generate the standard MIT License and copyright message."
+      (write-string (srfi-license-string who)))))

srfi-tools/library.sld

@@ -1,6 +1,6 @@
 (define-library (srfi-tools library)
   (export srfi-library-names-sxml
-          srfi-write-library-names)
+          srfi-generate-library-names)
   (import (scheme base)
           (scheme file)
           (srfi-tools private list)
@@ -45,13 +45,13 @@
                                                 num)))))))
                (srfi-list)))))))
 
-    (define (srfi-write-library-names)
+    (define (srfi-generate-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)
+    (define-command (generate-library-names)
       "Display the SRFI 97 library names."
-      (srfi-write-library-names))))
+      (srfi-generate-library-names))))

srfi-tools/main.sld

@@ -19,6 +19,7 @@
           (srfi-tools html)
           (srfi-tools info)
           (srfi-tools interactive)
+          (srfi-tools legal)
           (srfi-tools library)
           (srfi-tools mail)
           (srfi-tools missing)
@@ -49,13 +50,16 @@
                    (let* ((name (first args))
                           (args (rest args))
                           (command (command-by-name name)))
-                     (cond ((< (length args) (command-min-args command))
-                            (usage "Not enough args"))
-                           ((and (command-max-args command)
-                                 (> (length args) (command-max-args command)))
-                            (usage "Too many args"))
-                           (else
-                            (command-apply command args))))))))))
+                     (if (or (< (length args)
+                                (command-min-args command))
+                             (and (command-max-args command)
+                                  (> (length args)
+                                     (command-max-args command))))
+                         (apply usage
+                                "usage: srfi"
+                                name
+                                (command-arg-names command))
+                         (command-apply command args)))))))))
   (cond-expand
    (chibi
     (begin

srfi-tools/missing.sld

@@ -12,14 +12,14 @@
           (srfi-tools private command)
           (srfi-tools data)
           (srfi-tools path))
-  (export srfi-missing)
+  (export srfi-missing-ids)
   (begin
 
     (define (assoc-get get key alist)
       (let ((pair (assoc key alist)))
         (and pair (get pair))))
 
-    (define (missing-a-names html-file)
+    (define (missing-ids html-file)
       (let ((names (make-hash-table))
             (hrefs (make-hash-table)))
         (sxml-for-each
@@ -45,15 +45,13 @@
                         missing-names
                         (cons (car hrefs) missing-names)))))))
 
-    (define (missing-in-html-file html-file)
-      (disp "Missing id=\"...\" attributes in " html-file ":")
-      (let ((names (missing-a-names html-file)))
-        (for-each (lambda (name) (disp "  " name))
-                  (if (null? names) '("(none)") names))))
+    (define (srfi-missing-ids srfi)
+      (missing-ids (srfi-html-file srfi)))
 
-    (define (srfi-missing num)
-      (missing-in-html-file (srfi-html-file num)))
-
-    (define-command (missing num)
+    (define-command (check-ids num)
       "List missing 'id' attributes in HTML."
-      (srfi-missing (parse-srfi-number num)))))
+      (let* ((num (parse-srfi-number num))
+             (ids (srfi-missing-ids num)))
+        (disp "Missing id=\"...\" attributes in " (srfi-html-file num) ":")
+        (for-each (lambda (id) (disp "  " id))
+                  (if (null? ids) '("(none)") ids))))))

srfi-tools/pre.sld

@@ -1,13 +1,18 @@
 (define-library (srfi-tools pre)
   (export pre-srfi-home-dir
-          pre-srfi-list)
+          pre-srfi-dir
+          pre-srfi-list
+          pre-srfi-new)
   (import (scheme base)
+          (scheme file)
+          (srfi-tools private list)
           (srfi-tools private path)
           (srfi-tools private port)
           (srfi-tools private format)
           (srfi-tools private os)
           (srfi-tools private command)
           (srfi-tools data)
+          (srfi-tools legal)
           (srfi-tools path))
   (begin
 
@@ -24,9 +29,58 @@
       "Display the directory of unofficial \"pre-SRFI\" documents."
       (write-line (pre-srfi-home-dir)))
 
+    (define (pre-srfi-dir name)
+      (path-append (pre-srfi-home-dir) name))
+
+    (define-command (pre-dir name)
+      "Display the directory of unofficial \"pre-SRFI\" document NAME."
+      (write-line (pre-srfi-dir name)))
+
     (define (pre-srfi-list)
       (directory-files (pre-srfi-home-dir)))
 
     (define-command (pre-list)
       "Display the list of unofficial \"pre-SRFI\" documents."
-      (for-each disp (pre-srfi-list)))))
+      (for-each disp (pre-srfi-list)))
+
+    (define makefile-lines
+      '("all:"
+        "\tpandoc --from=gfm README.md -o README.html"
+        "\tpandoc --standalone README.html -o README.pdf"))
+
+    (define readme-lines
+      (append
+       (interpose
+        ""
+        '("# SRFI nnn: Title"
+          "by Firstname Lastname"
+          "## Status"
+          "Early Draft"
+          "## Abstract"
+          "## Issues"
+          "## Rationale"
+          "### Survey of prior art"
+          "## Specification"
+          "## Examples"
+          "## Implementation"
+          "## Acknowledgements"
+          "## References"
+          "## Copyright"))
+       '("")
+       (srfi-license-lines "Firstname Lastname (20XY)")))
+
+    (define (prepare-file filename lines)
+      (unless (file-exists? filename)
+        (with-output-to-file filename
+          (lambda () (for-each write-line lines)))))
+
+    (define (pre-srfi-new name)
+      (let ((dir (pre-srfi-dir name)))
+        (ensure-directory dir)
+        (prepare-file (path-append dir "Makefile") makefile-lines)
+        (prepare-file (path-append dir "README.md") readme-lines)
+        dir))
+
+    (define-command (pre-new name)
+      "Create new unofficial \"pre-SRFI\" document NAME."
+      (write-line (pre-srfi-new name)))))

srfi-tools/private/command.sld

@@ -11,6 +11,7 @@
    command-by-name
    command-list)
   (import (scheme base)
+          (srfi-tools private error)
           (srfi-tools private list)
           (srfi-tools private string))
   (begin
@@ -47,6 +48,7 @@
           (error "No such command" name)))
 
     (define (add-command! name arg-names help min-args max-args proc)
+      (assert (string? help) "Command help is not a string.")
       (let ((command (make-command name arg-names help min-args max-args proc)))
         (set! commands
               (list-sort command<?
@@ -60,7 +62,7 @@
          (let ((n-args (length '(args ...))))
            (add-command! (symbol->string 'name)
                          '(args ...)
-                         help
+                         'help
 			 n-args
                          n-args
 			 (lambda (args ...)

srfi-tools/private/error.sld

@@ -1,5 +1,6 @@
 (define-library (srfi-tools private error)
   (export user-error
+          assert
           usage)
   (import (scheme base)
           (scheme process-context)
@@ -13,4 +14,7 @@
           (write-line (string-join (map displayed args) " ")))
         (exit #f)))
 
+    (define (assert test . arguments)
+      (unless test (apply error arguments)))
+
     (define usage user-error)))

srfi-tools/private/list.sld

@@ -20,7 +20,8 @@
           rest
           pair<?
           reverse-pair<?
-          sorted-insert-unique)
+          sorted-insert-unique
+          interpose)
 
   (import (scheme base)
           (only (srfi 1)
@@ -71,4 +72,14 @@
                (loop (cons (first tail) before)
                      (rest tail)))
               (else
-               list))))))
+               list))))
+
+    ;; From Clojure.
+    (define (interpose delimiter list)
+      (if (null? list)
+          '()
+          (let loop ((new '()) (list list))
+            (if (null? (rest list))
+                (reverse (cons (first list) new))
+                (loop (cons* delimiter (first list) new)
+                      (rest list))))))))

srfi-tools/rss.scm

@@ -74,7 +74,7 @@
   (with-output-to-string
     (lambda () (sxml-display-as-html (srfi-rss-sxml)))))
 
-(define-command (rss)
+(define-command (generate-rss)
   "Generate the RSS file of SRFI updates."
   (let ((sxml (srfi-rss-sxml)))
     (disp "Writing " (srfi-rss-file))

srfi-tools/sxml-org.sld

@@ -2,6 +2,6 @@
   (export sxml-display-as-org)
   (import (scheme base)
 	  (scheme write)
-	  (srfi-tools assert)
+	  (srfi-tools private error)
 	  (srfi-tools private sxml))
   (include "sxml-org.scm"))

srfi-tools/tar.sld

@@ -24,7 +24,7 @@
         (download-url-into-file (srfi-tar-gz-url) filename)))
 
     (define-command (download-tar)
-      "Download the srfi.tgz file."
+      "Download the srfi.tgz archive."
       (srfi-download-tar))
 
     (define (srfi-unpack-matching-files match?)
@@ -66,7 +66,7 @@
                     stems))))))
 
     (define-command (unpack-tar num)
-      "Unpack the srfi.tgz file."
+      "Unpack the given SRFI from the srfi.tgz archive."
       (srfi-unpack-tar (parse-srfi-number num)))
 
     (define (srfi-unpack-tar-html)
@@ -75,5 +75,5 @@
          (string-suffix? ".html" (last path-parts)))))
 
     (define-command (unpack-tar-html)
-      "Unpack the .html files from the srfi.tgz file."
+      "Unpack all .html files from the srfi.tgz archive."
       (srfi-unpack-tar-html))))