138 lines
5.2 KiB
Racket
138 lines
5.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide schema->module-stx)
|
|
|
|
(require preserves)
|
|
(require racket/match)
|
|
(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")
|
|
|
|
(define (struct-stx name-pieces field-names)
|
|
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
|
|
|
|
(define (fold-Schema-definitions kc kn schema)
|
|
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
|
|
kn
|
|
(sorted-dict-entries (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 schema lookup-module-path)
|
|
(define imports (make-hash))
|
|
(define (import-ref! r)
|
|
(match-define (Ref 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))]
|
|
[(NamedSimplePattern_ 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-tuple* fixed-named-pats variable-named-pat)
|
|
(for-each walk fixed-named-pats)
|
|
(walk variable-named-pat)]
|
|
[(CompoundPattern-dict 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))]
|
|
`(require (prefix-in ,(module-path-prefix import) ,(lookup-module-path import)))))
|
|
|
|
(define (embedded-defs schema)
|
|
(match (Schema-embeddedType schema)
|
|
[(EmbeddedTypeName-false) `((define :parse-embedded values)
|
|
(define :embedded->preserves values))]
|
|
[(EmbeddedTypeName-Ref r) `((define (:parse-embedded input)
|
|
(match input
|
|
[,(pattern->match-pattern (SimplePattern-Ref r) 'output) output]
|
|
[_ eof]))
|
|
(define (:embedded->preserves input)
|
|
,(pattern->unparser (SimplePattern-Ref r) 'input)))]))
|
|
(define (struct-defs schema)
|
|
(fold-Schema-definitions
|
|
(lambda (name def acc)
|
|
(match (definition-ty def)
|
|
[(ty-union variants)
|
|
(for/fold [(acc (cons `(define (,(format-symbol "~a?" name) p)
|
|
(or ,@(for/list [(variant (in-list variants))]
|
|
`(,(format-symbol "~a-~a?" name (car variant)) p))))
|
|
acc))]
|
|
[(variant (in-list variants))]
|
|
(match-define (list variant-name variant-ty) variant)
|
|
(match variant-ty
|
|
[(ty-record fields)
|
|
(cons (struct-stx (list name variant-name) (map car fields)) acc)]
|
|
[(ty-unit)
|
|
(cons (struct-stx (list name variant-name) '()) acc)]
|
|
[_
|
|
(cons (struct-stx (list name variant-name) '(value)) acc)]))]
|
|
[(ty-record fields)
|
|
(cons (struct-stx (list name) (map car fields)) acc)]
|
|
[_
|
|
acc]))
|
|
'()
|
|
schema))
|
|
|
|
(define (parser-defs schema)
|
|
(map-Schema-definitions definition-parsers schema))
|
|
|
|
(define (unparser-defs schema)
|
|
(map-Schema-definitions definition-unparser schema))
|
|
|
|
(define (schema->module-stx name lookup-module-path schema)
|
|
(schema-check-problems! schema #:name name)
|
|
`(module ,name racket/base
|
|
(provide (all-defined-out))
|
|
,@(module-imports schema lookup-module-path)
|
|
,@(embedded-defs schema)
|
|
(require preserves)
|
|
(require preserves-schema/support)
|
|
(require racket/match)
|
|
(require racket/set)
|
|
(require racket/dict)
|
|
,@(struct-defs schema)
|
|
,@(parser-defs schema)
|
|
,@(unparser-defs schema)
|
|
))
|
|
|
|
(module+ main
|
|
(require racket/pretty)
|
|
(require racket/runtime-path)
|
|
|
|
(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)
|
|
(error 'compiler-rkt-main "~a" module-path))
|
|
metaschema))
|
|
|
|
(if #t
|
|
(with-output-to-file "gen/schema.rkt" #:exists 'replace
|
|
(lambda () (pretty-write metaschema-module-source)))
|
|
(pretty-write metaschema-module-source)))
|