257 lines
10 KiB
Racket
257 lines
10 KiB
Racket
#lang racket/base
|
|
|
|
(provide schema->module-stx
|
|
(struct-out schema-compiler-options)
|
|
(struct-out schema-translation-paths)
|
|
fold-Schema-definitions
|
|
map-Schema-definitions)
|
|
|
|
(require preserves)
|
|
(require racket/match)
|
|
(require (only-in racket/list append-map))
|
|
(require (only-in racket/string string-join))
|
|
(require (only-in racket/format ~a))
|
|
(require (only-in racket/syntax format-symbol))
|
|
|
|
(require "type.rkt")
|
|
(require "parser.rkt")
|
|
(require "unparser.rkt")
|
|
(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 field-names more)
|
|
`(struct ,name ,field-names #:transparent
|
|
,@more))
|
|
|
|
(define (ty->struct-field-names ty)
|
|
(match ty
|
|
[(ty-record fields) (map ty-field-name fields)] ;; not escaped here
|
|
[(ty-unit) '()]
|
|
[_ '(value)]))
|
|
|
|
(define (fold-Schema-definitions kc kn schema)
|
|
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
|
|
kn
|
|
(sorted-dict-entries (Definitions-value (Schema-definitions schema)))))
|
|
|
|
(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 translation-paths)
|
|
(define imports (make-hash))
|
|
(define (import-ref! r)
|
|
(match-define (Ref (ModulePath module-path) _name) r)
|
|
(when (not (null? module-path))
|
|
(hash-set! imports module-path #t)))
|
|
(define (walk x)
|
|
(match (unwrap x)
|
|
[(Definition-Pattern p) (walk p)]
|
|
[(Definition-or p0 p1 pN) (for-each walk (list* p0 p1 pN))]
|
|
[(Definition-and p0 p1 pN) (for-each walk (list* p0 p1 pN))]
|
|
[(Binding n p) (walk p)]
|
|
[(NamedAlternative _ p) (walk p)]
|
|
[(SimplePattern-seqof p) (walk p)]
|
|
[(SimplePattern-setof p) (walk p)]
|
|
[(SimplePattern-dictof kp vp)
|
|
(walk kp)
|
|
(walk vp)]
|
|
[(SimplePattern-Ref r) (import-ref! r)]
|
|
[(? SimplePattern?) (void)]
|
|
[(CompoundPattern-rec label-named-pat fields-named-pat)
|
|
(walk label-named-pat)
|
|
(walk fields-named-pat)]
|
|
[(CompoundPattern-tuple named-pats)
|
|
(for-each walk named-pats)]
|
|
[(CompoundPattern-tuplePrefix fixed-named-pats variable-named-pat)
|
|
(for-each walk fixed-named-pats)
|
|
(walk variable-named-pat)]
|
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
|
(for-each walk (map cdr (sorted-dict-entries entries)))]
|
|
[x (error 'module-imports "Unimplemented: ~v" x)]))
|
|
(match (Schema-embeddedType schema)
|
|
[(EmbeddedTypeName-false) (void)]
|
|
[(EmbeddedTypeName-Ref r) (import-ref! r)])
|
|
(map-Schema-definitions (lambda (n p) (walk p)) schema)
|
|
(for/list [(import (in-hash-keys imports))]
|
|
(match (lookup-module-path import)
|
|
[#f (error 'module-imports
|
|
"Reference to unknown module ~a in module ~a~a"
|
|
(string-join (map symbol->string import) ".")
|
|
name
|
|
(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)
|
|
(match (Schema-embeddedType schema)
|
|
[(EmbeddedTypeName-false) `((define :decode-embedded values)
|
|
(define :encode-embedded values))]
|
|
[(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
|
|
(define :encode-embedded ->preserve))]))
|
|
|
|
|
|
(define (parse!-definition name)
|
|
`(define ,(format-symbol "parse-~a!" name)
|
|
(parse-success-or-error ',(format-symbol "parse-~a" name)
|
|
,(format-symbol "parse-~a" name))))
|
|
|
|
(define ((compile-definition plugins) name def acc)
|
|
(define ty (definition-ty def))
|
|
(match def
|
|
|
|
[(? Definition-or?)
|
|
(define variants (ty-union-variants ty))
|
|
|
|
`[ (define (,(format-symbol "~a?" name) p)
|
|
(or ,@(for/list [(variant (in-list variants))]
|
|
`(,(format-symbol "~a-~a?" name (ty-variant-name variant)) p))))
|
|
|
|
,@(for/list [(variant (in-list variants))]
|
|
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
|
|
(define full-name (format-symbol "~a-~a" name variant-name))
|
|
(struct-stx full-name
|
|
(ty->struct-field-names variant-ty)
|
|
`[ #:methods gen:preservable
|
|
[(define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match preservable
|
|
[,(deconstruct full-name variant-ty)
|
|
,(pattern->unparser variant-pat 'src)]))]
|
|
|
|
]))
|
|
|
|
(define (,(format-symbol "parse-~a" name) input)
|
|
(match input
|
|
,@(for/list [(variant (in-list variants))]
|
|
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
|
|
`[,(pattern->match-pattern variant-pat 'dest)
|
|
,(construct (format-symbol "~a-~a" name variant-name) variant-ty)])
|
|
[_ eof]))
|
|
,(parse!-definition name)
|
|
|
|
,@acc ]]
|
|
|
|
[(Definition-and p0 p1 pN)
|
|
(define facets (list* p0 p1 pN))
|
|
|
|
`[ ,(struct-stx name
|
|
(ty->struct-field-names ty)
|
|
`[ #:methods gen:preservable
|
|
[(define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match preservable
|
|
[,(deconstruct name ty)
|
|
(merge-preserves
|
|
(lambda (a b) (if (equal? a b)
|
|
a
|
|
(error 'merge-preserves "Cannot merge")))
|
|
,@(append-map
|
|
(lambda (named-pat)
|
|
(match named-pat
|
|
[(NamedPattern-anonymous (Pattern-SimplePattern _)) '()]
|
|
[_ (list (pattern->unparser named-pat 'src))]))
|
|
facets))]))]
|
|
])
|
|
|
|
(define (,(format-symbol "parse-~a" name) input)
|
|
(match input
|
|
[(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
|
|
,(construct name ty)]
|
|
[_ eof]))
|
|
,(parse!-definition name)
|
|
|
|
,@acc ]]
|
|
|
|
[(Definition-Pattern pattern)
|
|
`[ ,(struct-stx name
|
|
(ty->struct-field-names ty)
|
|
`[ #:methods gen:preservable
|
|
[(define/generic *->preserve ->preserve)
|
|
(define (->preserve preservable)
|
|
(match preservable
|
|
[,(deconstruct name ty)
|
|
,(pattern->unparser pattern 'src)]))]
|
|
])
|
|
|
|
(define (,(format-symbol "parse-~a" name) input)
|
|
(match input
|
|
[,(pattern->match-pattern pattern 'dest)
|
|
,(construct name ty)]
|
|
[_ eof]))
|
|
,(parse!-definition name)
|
|
|
|
,@acc ]]))
|
|
|
|
(define (deconstruct name ty)
|
|
(match ty
|
|
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
|
[(ty-unit) `(,name)]
|
|
[_ `(,name src)]))
|
|
|
|
(define (construct name ty)
|
|
(match ty
|
|
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
|
[(ty-unit) `(,name)]
|
|
[_ `(,name dest)]))
|
|
|
|
(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) :decode-embedded :encode-embedded)
|
|
(rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
|
|
[:encode-embedded ,(format-symbol "encode-embedded:~a" name)]))
|
|
|
|
(require preserves)
|
|
(require preserves-schema/methods)
|
|
(require preserves-schema/support)
|
|
(require racket/match)
|
|
(require racket/set)
|
|
(require racket/dict)
|
|
(require (only-in racket/generic define/generic))
|
|
,@(module-imports name schema lookup-module-path translation-paths)
|
|
,@(embedded-defs schema)
|
|
,@(fold-Schema-definitions (compile-definition plugins) '() schema)
|
|
,@(for/list [(plugin (in-list plugins))] ((plugin 'schema) 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 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
|
|
#:translation-paths (schema-translation-paths schema-binary
|
|
schema-file
|
|
(simple-form-path target)
|
|
target)))
|
|
|
|
(if #t
|
|
(with-output-to-file target #:exists 'replace
|
|
(lambda () (pretty-write metaschema-module-source)))
|
|
(pretty-write metaschema-module-source)))
|