syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

batch-compile

This commit is contained in:
Tony Garnock-Jones 2021-05-27 09:52:58 +02:00
parent ef7cea09bf
commit 534018e3a4
1 changed files with 54 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt
View File

@ -1,8 +1,11 @@
#lang racket/base
(provide batch-compile)
(require "../main.rkt")
(require "../reader.rkt")
(require racket/match)
(require racket/pretty)
(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*))
@ -63,11 +66,43 @@
module-path
(file->schema full-input-path)))))
(define (batch-compile #:inputs inputs
#:additional-modules [additional-modules (hash)]
#:base-directory [base-directory #f]
#:output-directory [output-directory #f]
#:write-files? [write-files? #t])
(expand-globs inputs
base-directory
output-directory
(lambda (base-directory output-directory schemas)
(define index
(for/fold [(index additional-modules)]
[(s (in-list schemas))]
(hash-set index (schema-module-path s) (schema-relative-output-path s))))
(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 #f))
(schema-value s)
#:filename (schema-full-output-path s)))))
(when write-files?
(for [((output-path stx) (in-hash outputs))]
(make-parent-directory* output-path)
(with-output-to-file output-path #:exists 'replace
(lambda () (pretty-write stx)))))
outputs)))
(module+ main
(require racket/cmdline)
(require racket/pretty)
(define output-directory #f)
(define write-files? #t)
(define stdout? #f)
(define base-directory #f)
(define additional-modules '())
@ -78,6 +113,8 @@
(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)]
["--no-write-files" "Disables generation of output to the filesystem"
(set! write-files? #f)]
["--base" directory "Base directory for sources (default: common prefix)"
(set! base-directory directory)]
#:multi
@ -94,27 +131,21 @@
#:args input-glob
(set! inputs (map clean-input input-glob)))
(expand-globs inputs
base-directory
output-directory
(lambda (base-directory output-directory schemas)
(when (null? inputs)
(error 'preserves-schema-rkt "No inputs specified."))
(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
(batch-compile #:inputs inputs
#:additional-modules (for/hash [(e (in-list additional-modules))]
(values (car e) (cadr e)))
#:base-directory base-directory
#:output-directory output-directory
#:write-files? write-files?))
(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 #f))
(schema-value s)
#:filename (schema-full-output-path 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)))))))
(when stdout?
(for [((output-path stx) (in-hash outputs))]
(printf ";;-----------------------------------------------------------------\n")
(printf ";; ~a\n" output-path)
(newline)
(pretty-write stx)
(newline))))