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

Schema compiler plugins

This commit is contained in:
Tony Garnock-Jones 2021-06-02 06:56:44 +02:00
parent 64696ac184
commit bd68786f1c
3 changed files with 83 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))]

51
implementations/racket/preserves/preserves-schema/compiler.rkt
View File

@ -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)))

9
implementations/racket/preserves/preserves-schema/main.rkt
View File

@ -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))))