Initial commit

scheme-file-type.sld

@@ -0,0 +1,74 @@
+(define-library (scheme-file-type)
+  (export scheme-file-type
+          main)
+  (import (scheme base)
+          (srfi 1)
+          (srfi 13)
+          (srfi 193))
+  (begin
+
+    (define rest cdr)
+
+    (define primary-extension-map
+      '((".import.scm" "Chicken" "Scheme" "import" "library")
+        (".sld" "Scheme" "R7RS" "library" "source" "text")
+        (".sls" "Scheme" "R6RS" "library" "source" "text")
+        (".sps" "Scheme" "R6RS" "program" "source" "text")
+        (".sc" "Scheme" "source" "text")
+        (".sch" "Scheme" "source" "text")
+        (".scm" "Scheme" "source" "text")
+        (".scheme" "Scheme" "source" "text")))
+
+    (define secondary-extension-map
+      '((".chezscheme" "Chez")
+        (".guile" "Guile")
+        (".ikarus" "ikarus")
+        (".ironscheme" "IronScheme")
+        (".larceny" "Larceny")
+        (".loko" "Loko")
+        (".mzscheme" "MzScheme")
+        (".sagittarius" "Sagittarius")
+        (".vicare" "Vicare")
+        (".ypsilon" "Ypsilon")))
+
+    (define shebang-map
+      '(("chibi-scheme" "Chibi-Scheme")
+        ("gosh" "Gauche")
+        ("petite" "Petite Chez")
+        ("sash" "Sagittarius")))
+
+    (define (scheme-file-type filename)
+      (let ((primary-entry (find (lambda (entry)
+                                   (string-suffix-ci? (first entry) filename))
+                                 primary-extension-map)))
+        (and primary-entry
+             (let* ((primary-ext (first primary-entry))
+                    (primary-type (rest primary-entry))
+                    (without-primary-ext (string-drop-right
+                                          filename
+                                          (string-length primary-ext)))
+                    (secondary-entry (find (lambda (entry)
+                                             (string-suffix-ci? (first entry)
+                                                                without-primary-ext))
+                                           secondary-extension-map))
+                    (secondary-type (and secondary-entry (rest secondary-entry))))
+               (append (or secondary-type '())
+                       primary-type)))))
+
+    (define max-filename-width 50)
+
+    (define main
+      (lambda ignored
+        (let* ((filenames (command-args))
+               (width (min max-filename-width
+                           (fold max 0 (map string-length filenames)))))
+          (for-each (lambda (filename)
+                      (let ((gap (max 0 (- width (string-length filename))))
+                            (type (or (scheme-file-type filename)
+                                      '("unknown"))))
+                        (write-string filename)
+                        (write-string ": ")
+                        (write-string (make-string gap #\space))
+                        (write-string (string-join type " "))
+                        (newline)))
+                    filenames))))))