75 lines
2.9 KiB
Scheme
75 lines
2.9 KiB
Scheme
(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))))))
|