Initial commit

master
Lassi Kortela 1 year ago
commit 86e33a10ff

@ -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))))))
Loading…
Cancel
Save