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