lisp-mangler/translate.scm

116 lines
3.4 KiB
Scheme

(import (scheme base)
(scheme file)
(only (srfi 1) fold first second))
(define rest cdr)
(define (string-join list delimiter)
(if (null? list)
""
(fold (lambda (item result) (string-append result delimiter item))
(first list)
(rest list))))
(define (capitalize str)
(string-append (string (ascii-upcase (string-ref str 0)))
(string-copy str 1 (string-length str))))
(define (ascii-alphanumeric? char)
(or (char<=? #\0 char #\9)
(char<=? #\A char #\Z)
(char<=? #\a char #\z)))
(define (ascii-upcase char)
(if (char<=? #\a char #\z)
(integer->char (+ (char->integer #\A)
(- (char->integer char)
(char->integer #\a))))
char))
(define (translate-words str)
(define names
'((#\. "dot")
(#\? "p")
(#\! "bang")
(#\+ "plus")
(#\* "star")
(#\- "minus")
(#\/ "slash")
(#\< "less")
(#\= "equal")
(#\> "greater")))
(define (eject a b words)
(if (< a b)
(cons (string-copy str a b) words)
words))
(let loop ((a 0) (b 0) (words '()))
(cond ((= b (string-length str))
(reverse (eject a b words)))
(else
(let* ((char (string-ref str b))
(name* (assoc char names))
(name (and name* (second name*))))
(cond ((and (char=? #\- char)
(< b (- (string-length str) 1)))
(loop (+ b 1)
(+ b 1)
(eject a b words)))
((and (char=? #\> char)
(not (null? words))
(= a b))
(loop (+ b 1)
(+ b 1)
(cons "to" words)))
(name
(loop (+ b 1)
(+ b 1)
(cons name (eject a b words))))
((ascii-alphanumeric? char)
(loop a (+ b 1) words))
(else
(error "What?" char))))))))
(define (translate-camel str)
(string-join (map capitalize (translate-words str))
""))
(define (translate-under str)
(string-join (translate-words str) "_"))
(define (read-all-lines)
(let loop ((lines '()))
(let ((line (read-line)))
(if (eof-object? line)
(reverse lines)
(loop (cons line lines))))))
(define (writing file)
(write-string "Writing ")
(write-string file)
(newline))
(define (process translate from-file to-file)
(let* ((lines (with-input-from-file from-file read-all-lines))
(width (fold max 0 (map string-length lines))))
(writing to-file)
(with-output-to-file to-file
(lambda ()
(for-each (lambda (line)
(let ((pad (max 0 (- width (string-length line)))))
(write-string line)
(write-string (make-string (+ pad 2) #\space))
(write-string (translate line))
(newline)))
lines)))))
(define (main)
(define sa string-append)
(for-each (lambda (file)
(let ((source (sa "source/" file)))
(process translate-camel source (sa "target-camel/" file))
(process translate-under source (sa "target-under/" file))))
'("common-lisp"
"r7rs-small")))
(main)