115 lines
3.1 KiB
Scheme
115 lines
3.1 KiB
Scheme
;;
|
|
;; schemify-tree.scm
|
|
;;
|
|
;; Converts directory tree into assoc dictionary.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2025 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
(import (chicken process-context)
|
|
(chicken file)
|
|
(chicken pathname)
|
|
(chicken format)
|
|
(chicken io))
|
|
|
|
(define (get-argv)
|
|
(let* ((args (argv))
|
|
(rargs (member "--" args)))
|
|
(if rargs
|
|
(cdr rargs)
|
|
(if (equal? (car args) "csi")
|
|
'()
|
|
(cdr args)))))
|
|
|
|
(define args0 (get-argv))
|
|
(define args (if (null? args0)
|
|
'("../frontend/dist" "frontend" "frontend-lookup")
|
|
args0))
|
|
(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))
|
|
(key0 (substring fpath dir-len))
|
|
(key (if (eq? (string-ref key0 0) #\/)
|
|
(substring key0 1)
|
|
key0))
|
|
(value (with-input-from-file fpath read-string)))
|
|
(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 ()
|
|
(display `(declare (unit ,name)))
|
|
(newline)
|
|
(write (make-tree-module dir name getter))
|
|
(newline))))
|
|
|
|
(compile-tree-module dir modname lookupname)
|