diff --git a/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt b/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt index dc66e04..2defb6e 100644 --- a/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt +++ b/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt @@ -1,6 +1,6 @@ #lang racket/base -(provide batch-compile) +(provide batch-compile load-plugins) (require "../main.rkt") (require "../reader.rkt") @@ -11,12 +11,10 @@ (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 +(struct schema (paths module-path - value) #:transparent) + value) + #:transparent) (define (clean-input p) (path->string (simplify-path (path->complete-path (expand-user-path p)) #f))) @@ -59,10 +57,10 @@ (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 + (schema (schema-translation-paths 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))))) @@ -70,7 +68,8 @@ #:additional-modules [additional-modules (hash)] #:base-directory [base-directory #f] #:output-directory [output-directory #f] - #:write-files? [write-files? #t]) + #:write-files? [write-files? #t] + #:plugins [plugins '()]) (expand-globs inputs base-directory output-directory @@ -79,16 +78,23 @@ (define index (for/fold [(index additional-modules)] [(s (in-list schemas))] - (hash-set index (schema-module-path s) (schema-relative-output-path s)))) + (hash-set index + (schema-module-path s) + (schema-translation-paths-relative-output-path (schema-paths 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))))) + (match-define (schema (and tps (schema-translation-paths fi ri fo ro)) + mp + v) + s) + (values fo + (schema->module-stx + (last mp) + (lambda (module-path) (hash-ref index module-path #f)) + v + #:translation-paths tps + #:plugins plugins)))) (when write-files? (for [((output-path stx) (in-hash outputs))] @@ -98,6 +104,10 @@ outputs))) +(define (load-plugins mods) + (for/list [(mod mods)] + (dynamic-require mod 'schema-compiler-plugin))) + (module+ main (require racket/cmdline) @@ -107,6 +117,7 @@ (define base-directory #f) (define additional-modules '()) (define inputs '()) + (define plugin-mods '()) (command-line #:once-each ["--output" directory "Output directory for modules (default: next to sources)" @@ -128,19 +139,26 @@ (cons (list (map string->symbol (string-split namespace-str ".")) path-str) additional-modules))))] + [("--plugin-lib" "-l") lib-path "Load compiler plugin library" + (set! plugin-mods (cons (string->symbol lib-path) plugin-mods))] + [("--plugin-file" "-f") rkt-file-path "Load compiler plugin source file" + (set! plugin-mods (cons rkt-file-path plugin-mods))] #:args input-glob (set! inputs (map clean-input input-glob))) (when (null? inputs) (error 'preserves-schema-rkt "No inputs specified.")) + (set! plugin-mods (reverse plugin-mods)) + (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?)) + #:write-files? write-files? + #:plugins (load-plugins plugin-mods))) (when stdout? (for [((output-path stx) (in-hash outputs))] diff --git a/implementations/racket/preserves/preserves-schema/compiler.rkt b/implementations/racket/preserves/preserves-schema/compiler.rkt index c45a0eb..f5b407b 100644 --- a/implementations/racket/preserves/preserves-schema/compiler.rkt +++ b/implementations/racket/preserves/preserves-schema/compiler.rkt @@ -1,6 +1,8 @@ #lang racket/base -(provide schema->module-stx) +(provide schema->module-stx + (struct-out schema-compiler-options) + (struct-out schema-translation-paths)) (require preserves) (require racket/match) @@ -14,6 +16,17 @@ (require "checker.rkt") (require "gen/schema.rkt") +(struct schema-compiler-options (name + lookup-module-path + translation-paths) + #:transparent) + +(struct schema-translation-paths (full-input-path + relative-input-path + full-output-path + relative-output-path) + #:transparent) + (define (struct-stx name-pieces field-names) `(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab)) @@ -25,7 +38,7 @@ (define (map-Schema-definitions proc schema) (fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema)) -(define (module-imports name schema lookup-module-path filename) +(define (module-imports name schema lookup-module-path translation-paths) (define imports (make-hash)) (define (import-ref! r) (match-define (Ref module-path _name) r) @@ -66,7 +79,9 @@ "Reference to unknown module ~a in module ~a~a" (string-join (map symbol->string import) ".") name - (if filename (format " (~a)" filename) ""))] + (match translation-paths + [(schema-translation-paths _ (? path-string? p) _ _) (format " (~a)" p)] + [_ ""]))] [path `(require (prefix-in ,(module-path-prefix import) ,path))]))) (define (embedded-defs schema) @@ -109,13 +124,17 @@ (define (unparser-defs schema) (map-Schema-definitions definition-unparser schema)) -(define (schema->module-stx name lookup-module-path schema #:filename [filename #f]) +(define (schema->module-stx name lookup-module-path schema + #:translation-paths [translation-paths #f] + #:plugins [plugins '()] + ) (schema-check-problems! schema #:name name) + (define options (schema-compiler-options name lookup-module-path translation-paths)) `(module ,name racket/base (provide (except-out (all-defined-out) :parse-embedded :embedded->preserves) (rename-out [:parse-embedded ,(format-symbol ":parse-embedded:~a" name)] [:embedded->preserves ,(format-symbol ":embedded->preserves:~a" name)])) - ,@(module-imports name schema lookup-module-path filename) + ,@(module-imports name schema lookup-module-path translation-paths) ,@(embedded-defs schema) (require preserves) (require preserves-schema/support) @@ -125,20 +144,30 @@ ,@(struct-defs schema) ,@(parser-defs schema) ,@(unparser-defs schema) + ,@(for/list [(plugin (in-list plugins))] (plugin schema options)) )) (module+ main (require racket/pretty) (require racket/runtime-path) + (require racket/path) + + (define-runtime-path schema-dir "../../../../schema") + (define schema-file "schema.bin") + (define schema-binary (build-path schema-dir schema-file)) + (define target "gen/schema.rkt") - (define-runtime-path schema-binary "../../../../schema/schema.bin") (define metaschema (parse-Schema (with-input-from-file schema-binary read-preserve))) - (define metaschema-module-source (schema->module-stx 'gen-schema - (lambda (module-path) #f) - metaschema - #:filename schema-binary)) + (define metaschema-module-source + (schema->module-stx 'gen-schema + (lambda (module-path) #f) + metaschema + #:translation-paths (schema-translation-paths schema-binary + schema-file + (simple-form-path target) + target))) (if #t - (with-output-to-file "gen/schema.rkt" #:exists 'replace + (with-output-to-file target #:exists 'replace (lambda () (pretty-write metaschema-module-source))) (pretty-write metaschema-module-source))) diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt index 9e6ccc0..d6d2967 100644 --- a/implementations/racket/preserves/preserves-schema/main.rkt +++ b/implementations/racket/preserves/preserves-schema/main.rkt @@ -1,8 +1,8 @@ #lang racket/base -(provide schema->module-stx) +(provide (all-from-out "compiler.rkt")) -(require (only-in "compiler.rkt" schema->module-stx)) +(require "compiler.rkt") (module+ reader (provide (rename-out [read-preserves-schema-module read-syntax])) @@ -13,4 +13,7 @@ (string->symbol (path->string (path-replace-extension filename ""))) (lambda (module-path) #f) (port->schema src p) - #:filename src))) + #:translation-paths (schema-translation-paths src + filename + #f + #f))))