83 lines
2 KiB
Scheme
83 lines
2 KiB
Scheme
(import (chicken process-context)
|
|
srfi-4
|
|
(chicken file)
|
|
(chicken pathname)
|
|
(chicken format))
|
|
|
|
(define (get-argv)
|
|
(let* ((args (argv))
|
|
(rargs (member "--" args)))
|
|
(if rargs
|
|
(cdr rargs)
|
|
(if (equal? (car args) "csi")
|
|
'()
|
|
(cdr args)))))
|
|
|
|
(define args (get-argv))
|
|
(when (< (length args) 1)
|
|
(display "usage: schemify-tree dir")
|
|
(newline)
|
|
(exit 1))
|
|
|
|
(define dir (car args))
|
|
(define modname
|
|
(if (null? (cdr args))
|
|
'frontend-data
|
|
(string->symbol (cadr args))))
|
|
(define lookupname
|
|
(if (or (null? (cdr args))
|
|
(null? (cddr args)))
|
|
'frontend-lookup
|
|
(string->symbol (caddr args))))
|
|
|
|
(define (scan-dir-tree dir . cs)
|
|
(let ((col (if (null? cs)
|
|
'()
|
|
(car cs)))
|
|
(filenames (directory dir)))
|
|
(let loop ((filenames filenames)
|
|
(col col))
|
|
(if (null? filenames)
|
|
col
|
|
(let* ((filename (car filenames))
|
|
(fpath (make-pathname dir filename)))
|
|
(if (directory-exists? fpath)
|
|
(loop (cdr filenames)
|
|
(scan-dir-tree fpath col))
|
|
(loop (cdr filenames)
|
|
(cons fpath col))))))))
|
|
|
|
(define (load-dir-tree dir tree)
|
|
(let ((dir-len (string-length dir)))
|
|
(let loop ((tree tree)
|
|
(alst '()))
|
|
(if (null? tree)
|
|
alst
|
|
(let* ((fpath (car tree))
|
|
(key (substring fpath dir-len))
|
|
(value (with-input-from-file fpath read-u8vector)))
|
|
(loop (cdr tree)
|
|
(cons (cons key value)
|
|
alst)))))))
|
|
|
|
(define (make-tree-module dir name getter)
|
|
(let* ((tree (scan-dir-tree dir))
|
|
(alst (load-dir-tree dir tree)))
|
|
`(module ,name (,getter)
|
|
(import scheme srfi-4 (chicken base))
|
|
(define alst ',alst)
|
|
(define (,getter key . vs)
|
|
(let ((klst (assoc key alst)))
|
|
(if klst
|
|
(cdr klst)
|
|
(if (null? vs)
|
|
(error ,getter "key not found" key)
|
|
(car vs))))))))
|
|
|
|
(define (compile-tree-module dir name getter)
|
|
(with-output-to-file (format "~a.scm" name)
|
|
(lambda ()
|
|
(write (make-tree-module dir name getter))
|
|
(newline))))
|
|
|
|
(compile-tree-module dir modname lookupname)
|