125 lines
5.9 KiB
Racket
125 lines
5.9 KiB
Racket
#lang racket/base
|
|
|
|
(require "../main.rkt")
|
|
(require "../reader.rkt")
|
|
(require racket/match)
|
|
(require (only-in racket/list index-of append-map remove-duplicates last drop-right))
|
|
(require (only-in racket/string string-split string-prefix?))
|
|
(require (only-in racket/file make-parent-directory*))
|
|
(require file/glob)
|
|
|
|
(struct schema (full-input-path
|
|
relative-input-path
|
|
full-output-path
|
|
relative-output-path
|
|
module-path
|
|
value) #:transparent)
|
|
|
|
(define (clean-input p)
|
|
(path->string (simplify-path (path->complete-path (expand-user-path p)) #f)))
|
|
|
|
(define (compute-base paths)
|
|
(match paths
|
|
['() "."]
|
|
[(list p) (path->string (simplify-path (build-path p 'up) #f))]
|
|
[_ (let try-index ((i 0))
|
|
(let scan-paths ((paths paths) (ch #f))
|
|
(match paths
|
|
['() (try-index (+ i 1))]
|
|
[(cons p more-paths)
|
|
(cond [(= i (string-length p)) (substring p 0 i)]
|
|
[(not ch) (scan-paths more-paths (string-ref p i))]
|
|
[(eqv? ch (string-ref p i)) (scan-paths more-paths ch)]
|
|
[else (substring p 0 i)])])))]))
|
|
|
|
(define (expand-globs globs base0 output-directory0 k)
|
|
(define base (or base0 (compute-base globs)))
|
|
(define output-directory (or (and output-directory0 (clean-input output-directory0))
|
|
base))
|
|
(k base
|
|
output-directory
|
|
(for/list [(full-input-path (in-list (map path->string
|
|
(remove-duplicates
|
|
(append-map (lambda (g)
|
|
(define results (glob g))
|
|
(when (null? results)
|
|
(error 'preserves-schema-rkt
|
|
"Input not found: ~v" g))
|
|
results)
|
|
globs)))))]
|
|
(when (not (string-prefix? full-input-path base))
|
|
(error 'preserves-schema-rkt "Input filename ~v falls outside base ~v"
|
|
full-input-path
|
|
base))
|
|
(define relative-input-path (substring full-input-path (string-length base)))
|
|
(define module-path (for/list [(p (explode-path relative-input-path))]
|
|
(string->symbol (path->string (path-replace-extension p "")))))
|
|
(define relative-output-path
|
|
(path->string (path-replace-extension relative-input-path ".rkt")))
|
|
(schema full-input-path
|
|
relative-input-path
|
|
(path->string (build-path output-directory relative-output-path))
|
|
relative-output-path
|
|
module-path
|
|
(file->schema full-input-path)))))
|
|
|
|
(module+ main
|
|
(require racket/cmdline)
|
|
(require racket/pretty)
|
|
|
|
(define output-directory #f)
|
|
(define stdout? #f)
|
|
(define base-directory #f)
|
|
(define additional-modules '())
|
|
(define inputs '())
|
|
|
|
(command-line #:once-each
|
|
["--output" directory "Output directory for modules (default: next to sources)"
|
|
(set! output-directory directory)]
|
|
["--stdout" "Prints each module to stdout one after the other instead of writing them to files in the `--output` directory"
|
|
(set! stdout? #t)]
|
|
["--base" directory "Base directory for sources (default: common prefix)"
|
|
(set! base-directory directory)]
|
|
#:multi
|
|
["--module" namespace=path "Additional Namespace=path import"
|
|
(let ((i (index-of (string->list namespace=path) #\=)))
|
|
(when (not i)
|
|
(error '--module "Argument must be Namespace=path: ~v" namespace=path))
|
|
(let* ((namespace-str (substring namespace=path 0 i))
|
|
(path-str (substring namespace=path (+ i 1))))
|
|
(set! additional-modules
|
|
(cons (list (map string->symbol (string-split namespace-str "."))
|
|
path-str)
|
|
additional-modules))))]
|
|
#:args input-glob
|
|
(set! inputs (map clean-input input-glob)))
|
|
|
|
(expand-globs inputs
|
|
base-directory
|
|
output-directory
|
|
(lambda (base-directory output-directory schemas)
|
|
|
|
(define index (make-hash))
|
|
(for [(s (in-list schemas))]
|
|
(hash-set! index (schema-module-path s) (schema-relative-output-path s)))
|
|
(for [(e (in-list additional-modules))]
|
|
(hash-set! index (car e) (cadr e)))
|
|
|
|
(define outputs
|
|
(for/hash [(s (in-list schemas))]
|
|
(values (schema-full-output-path s)
|
|
(schema->module-stx (last (schema-module-path s))
|
|
(lambda (module-path)
|
|
(hash-ref index
|
|
module-path
|
|
(lambda ()
|
|
(error 'preserves-schema-rkt
|
|
"Undefined module: ~a"
|
|
module-path))))
|
|
(schema-value s)))))
|
|
|
|
(for [((output-path stx) (in-hash outputs))]
|
|
(make-parent-directory* output-path)
|
|
(with-output-to-file output-path #:exists 'replace
|
|
(lambda () (pretty-write stx)))))))
|