More SRFI tool patches

srfi-tools/asciidoc.sld

@@ -65,11 +65,13 @@
               (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.
+    ;; This converts a SRFI written in AsciiDoc into HTML.
+    ;;
+    ;; Note that HTML is the required submission 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)
       "Convert SRFI written in AsciiDoc into HTML."
       (srfi-from-asciidoc asciidoc-file))))

srfi-tools/data.scm

@@ -251,9 +251,14 @@
 (define (srfi-drafts)
   (filter srfi-draft? (srfi-list)))
 
+(define (srfi-age-string srfi)
+  (format "~a days"
+          (days-between (iso-date->date (srfi-draft-date srfi))
+                        (current-date))))
+
 (define-command (drafts)
   "Display a list of all the draft SRFIs."
-  (write-custom-srfi-list (srfi-drafts) "since" srfi-draft-date))
+  (write-custom-srfi-list (srfi-drafts) srfi-age-string))
 
 (define (srfi-by-author name)
   (filter (lambda (srfi)
@@ -282,3 +287,17 @@
  1
  #f
  (lambda words (write-srfi-list (srfi-search words))))
+
+(define (srfi-what . numbers)
+  (filter (lambda (srfi) (member (srfi-number srfi) numbers))
+          (srfi-list)))
+
+(add-command!
+ "what"
+ '(number ...)
+ "Display a one-line summmary of the given SRFI <number>s."
+ 1
+ #f
+ (lambda numbers
+   (write-srfi-list
+    (apply srfi-what (map parse-srfi-number numbers)))))

srfi-tools/data.sld

@@ -39,9 +39,6 @@
           write-string-about-srfi
           write-line-about-srfi
 
-          srfi-default-command
-          srfi-default-number-command
-
 	  keyword->name
 
 	  write-custom-srfi-list
@@ -54,9 +51,11 @@
           (scheme read)
 	  (srfi-tools private error)
 	  (srfi-tools private list)
+          (srfi-tools private format)
           (srfi-tools private string)
           (srfi-tools private port)
           (srfi-tools private file)
+          (srfi-tools private time)
           (srfi-tools private command)
           (srfi-tools core)
           (srfi-tools path))

srfi-tools/git.sld

@@ -1,6 +1,7 @@
 (define-library (srfi-tools git)
   (export srfi-git-https-url
-          srfi-git-ssh-url)
+          srfi-git-ssh-url
+          srfi-clone)
   (import (scheme base)
           (scheme file)
           (srfi-tools private command)
@@ -23,4 +24,26 @@
 
     (define-command (git-ssh-url num)
       "Display the Git SSH URL for SRFI <num>."
-      (write-line-about-srfi srfi-git-ssh-url num))))
+      (write-line-about-srfi srfi-git-ssh-url num))
+
+    (define (srfi-clone num)
+      (let ((dir (srfi-dir num)))
+        (ensure-directory dir)
+        (with-current-directory
+         dir
+         (lambda ()
+           (when (run-program/get-boolean '("git" "rev-parse" "--git-dir"))
+             (error "That SRFI is already under git version control."))
+           (run-program '("git" "init"))
+           (run-program `("git" "remote" "add" "origin"
+                          ,(srfi-git-https-url num)))
+           (run-program '("git" "add" "."))
+           (run-program '("git" "pull"
+                          "--autostash"
+                          "--set-upstream"
+                          "origin" "master"))
+           (write-line dir)))))
+
+    (define-command (clone num)
+      "Pull SRFI <num> from its git version control repository."
+      (srfi-clone (parse-srfi-number num)))))

srfi-tools/local.example.sld

@@ -2,6 +2,7 @@
   (import (scheme base)
           (srfi-tools private command)
           (srfi-tools private external)
+          (srfi-tools core)
           (srfi-tools data)
           (srfi-tools path)
           (srfi-tools interactive))

srfi-tools/main.sld

@@ -12,6 +12,7 @@
   (import (srfi-tools asciidoc)
           (srfi-tools chart)
           (srfi-tools checklink)
+          (srfi-tools core)
           (srfi-tools count)
           (srfi-tools data)
           (srfi-tools generate)

srfi-tools/private/command.sld

@@ -58,14 +58,15 @@
 
     (define-syntax define-command
       (syntax-rules ()
-        ((define-command (name args ...) help body ...)
+        ((define-command (name args ...) help body0 body ...)
          (let ((n-args (length '(args ...))))
            (add-command! (symbol->string 'name)
                          '(args ...)
                          'help
 			 n-args
                          n-args
 			 (lambda (args ...)
+                           body0
                            body ...))))))
 
     (define (command-list)

srfi-tools/private/os.sld

@@ -3,7 +3,9 @@
           create-directory
           ensure-directory
           directory-files
+          with-current-directory
           run-program
+          run-program/get-boolean
           run-program/get-output-string
           run-program/file-to-file
 

srfi-tools/private/sysdep.chibi.scm

@@ -25,6 +25,9 @@
     (remove (lambda (name) (member name '("." "..")))
             (chibi:directory-files path)))
 
+  (define (with-current-directory path thunk)
+    (chibi:with-directory path thunk))
+
   ;; TODO: Copied from Chibi's <lib/chibi/process.scm>.
   (define (execute-returned cmd)
     ;; we only arrive here if execute fails
@@ -67,5 +70,11 @@
                   (unless (eqv? status 0)
                     (error "Command failed")))))))))))
 
+  (define (run-program/get-boolean command+args)
+    (let* ((output+error+status
+            (chibi:process->output+error+status command+args))
+           (status (list-ref output+error+status 2)))
+      (eqv? status 0)))
+
   (define (run-program/get-output-string command+args)
     (chibi:process->string command+args)))

srfi-tools/private/sysdep.chicken.scm

@@ -10,6 +10,14 @@
 (define (directory-files path)
   (chicken:directory path))
 
+(define (with-current-directory path thunk)
+  (let ((old (chicken:current-directory)))
+    (chicken:change-directory path)
+    (dynamic-wind
+        (lambda () (values))
+        thunk
+        (lambda () (chicken:change-directory old)))))
+
 (define (handle-exit command+args thunk)
   (let-values (((number normal-exit? pid) (thunk)))
     (unless normal-exit?

srfi-tools/private/sysdep.gauche.scm

@@ -1,11 +1,11 @@
 (import (scheme base)
         (scheme file)
-        (prefix (only (srfi 170)
-                      create-directory
-                      rename-file)
+        (prefix (srfi 170)
                 srfi-170:)
         (prefix (only (gauche base)
-                      make-keyword)
+                      make-keyword
+                      sys-chdir
+                      sys-getcwd)
                 gauche:)
         (prefix (gauche process)
                 gauche:)
@@ -26,18 +26,36 @@
   (define (directory-files path)
     (srfi-170:directory-files path #t))
 
+  (define (with-current-directory path thunk)
+    (let ((old (gauche:sys-getcwd)))
+      (gauche:sys-chdir path)
+      (dynamic-wind
+          (lambda () (values))
+          thunk
+          (lambda () (gauche:sys-chdir old)))))
+
   (define (run-program command+args)
-    (gauche:do-process command+args)
+    (gauche:do-process! command+args)
     (values))
 
   (define (run-program/file-to-file command+args
                                     input-filename
                                     output-filename)
+    (gauche:do-process! command+args
+                        (gauche:make-keyword "input")
+                        input-filename
+                        (gauche:make-keyword "output")
+                        output-filename)
+    (values))
+
+  (define (run-program/get-boolean command+args)
     (gauche:do-process command+args
                        (gauche:make-keyword "input")
-                       input-filename
+                       (gauche:make-keyword "null")
                        (gauche:make-keyword "output")
-                       output-filename))
+                       (gauche:make-keyword "null")
+                       (gauche:make-keyword "error")
+                       (gauche:make-keyword "null")))
 
   (define (run-program/get-output-string command+args)
     (gauche:with-input-from-process command+args read-all-chars)))

srfi-tools/private/sysdep.sld

@@ -3,7 +3,9 @@
           create-directory
           ensure-directory
           directory-files
+          with-current-directory
           run-program
+          run-program/get-boolean
           run-program/get-output-string
           run-program/file-to-file)
   (cond-expand
@@ -16,6 +18,10 @@
                           directory
                           rename-file)
                     chicken:)
+            (prefix (only (chicken process-context)
+                          change-directory
+                          current-directory)
+                    chicken:)
             (prefix (only (scsh-process)
                           run
                           run/port

srfi-tools/private/time.sld

@@ -9,6 +9,7 @@
           time<?)
   (export date->iso-date
           date->julian
+          days-between
           iso-date-year
           iso-date-month
           iso-date-day
@@ -36,6 +37,10 @@
 					 ; julian-date->date on non-integer
 					 ; values.
 
+    (define (days-between start-date end-date)
+      (- (truncate (date->julian-day end-date))
+         (truncate (date->julian-day start-date))))
+
     (define (iso-date-year string)
       (string->number (string-copy string 0 4)))