Add signature commands

srfi-tools/main.sld

@@ -29,6 +29,7 @@
           (srfi-tools path)
           (srfi-tools pre)
           (srfi-tools rss)
+          (srfi-tools signature)
           (srfi-tools tar)
           (srfi-tools toc))
   (cond-expand

srfi-tools/path.sld

@@ -4,6 +4,7 @@
           srfi-home-dir
           srfi-common-dir
           srfi-data-file
+          srfi-signatures-file
           srfi-rss-file
           srfi-dir
           srfi-html-file
@@ -40,6 +41,9 @@
       "Display the pathname of the SRFI database file."
       (write-line (srfi-data-file)))
 
+    (define (srfi-signatures-file)
+      (path-append (srfi-common-dir) "index" "signatures.scm"))
+
     (define (srfi-rss-file)
       (path-append (srfi-home-dir) "srfi-common" "srfi.rss"))
 

srfi-tools/private/list.sld

@@ -23,6 +23,7 @@
           pair<?
           reverse-pair<?
           sorted-insert-unique
+          for-each-between
           interpose)
 
   (import (scheme base)
@@ -76,6 +77,12 @@
               (else
                list))))
 
+    (define (for-each-between visit between list)
+      (unless (null? list)
+        (visit (first list))
+        (for-each (lambda (item) (between) (visit item))
+                  (rest list))))
+
     ;; From Clojure.
     (define (interpose delimiter list)
       (if (null? list)

srfi-tools/private/pretty-print.sld

@@ -1,6 +1,8 @@
 (define-library (srfi-tools private pretty-print)
-  (export pretty-print)
-  (import (scheme base))
+  (export pretty-print
+          pretty-print-all)
+  (import (scheme base)
+          (srfi-tools private list))
 
   (cond-expand
    (chibi
@@ -24,4 +26,9 @@
     (begin
       (define (pretty-print obj)
         (write obj)
-        (newline))))))
+        (newline)))))
+
+  (begin
+
+    (define (pretty-print-all list)
+      (for-each-between pretty-print newline list))))

srfi-tools/signature.sld

@@ -0,0 +1,76 @@
+(define-library (srfi-tools signature)
+  (export srfi-signatures-data
+          srfi-signatures
+          srfi-identifier-list
+          srfi-identifier-signatures
+          srfi-identifier-search)
+  (import (scheme base)
+          (scheme char)
+          (scheme file)
+
+          (srfi-tools private command)
+          (srfi-tools private list)
+          (srfi-tools private port)
+          (srfi-tools private pretty-print)
+          (srfi-tools private string)
+
+          (srfi-tools core)
+          (srfi-tools path))
+  (begin
+
+    (define (srfi-signatures-data)
+      (with-input-from-file (srfi-signatures-file)
+        read-all))
+
+    (define (signature-source sig)
+      (and (list? sig)
+           (let ((entry (assoc 'source sig)))
+             (and entry (second entry)))))
+
+    (define (signature-identifier sig)
+      (and (list? sig)
+           (list? (first sig))
+           (list? (second (first sig)))
+           (equal? 'signature (first (first sig)))
+           (first (second (first sig)))))
+
+    (define (srfi-signatures num)
+      (filter (lambda (sig) (equal? `(srfi ,num) (signature-source sig)))
+              (srfi-signatures-data)))
+
+    (define-command (signatures num)
+      "Output the type signatures from SRFI <num>."
+      (pretty-print-all (srfi-signatures (parse-srfi-number num))))
+
+    (define (srfi-identifier-list)
+      (filter-map signature-identifier (srfi-signatures-data)))
+
+    (define-command (identifier-list)
+      "Output the type signatures from all SRFIs."
+      (for-each disp (srfi-identifier-list)))
+
+    (define (srfi-identifier-signatures identifier)
+      (let ((identifier (if (string? identifier)
+                            (string->symbol identifier)
+                            identifier)))
+        (filter (lambda (sig) (equal? identifier (signature-identifier sig)))
+                (srfi-signatures-data))))
+
+    (define-command (identifier-signatures identifier)
+      "Output the type signatures for <identifier> from all SRFIs."
+      (pretty-print-all (srfi-identifier-signatures identifier)))
+
+    (define (srfi-identifier-search string)
+      (list-sort
+       (pair<? string<? (lambda (a b) (< (second a) (second b))))
+       (filter-map (lambda (sig)
+                     (let* ((id (signature-identifier sig))
+                            (id (and id (symbol->string id))))
+                       (and id
+                            (string-contains id string)
+                            (cons id (signature-source sig)))))
+                   (srfi-signatures-data))))
+
+    (define-command (identifier-search string)
+      "Output the type signatures for <identifier> from all SRFIs."
+      (display-two-column-table (srfi-identifier-search string)))))