74 lines
2.6 KiB
Racket
74 lines
2.6 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 "gen/schema.rkt")
|
|
|
|
(define (struct-stx name-pieces field-names)
|
|
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
|
|
|
|
(define (struct-defs schema)
|
|
(reverse (for/fold [(acc '())]
|
|
[((name def) (in-hash (Schema-definitions schema)))]
|
|
(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]))))
|
|
|
|
(define (parser-defs schema)
|
|
(for/list [((name def) (in-hash (Schema-definitions schema)))]
|
|
(definition-parser name def)))
|
|
|
|
(define (unparser-defs schema)
|
|
(for/list [((name def) (in-hash (Schema-definitions schema)))]
|
|
(definition-unparser name def)))
|
|
|
|
(define (schema->module-stx name schema)
|
|
`(module ,name racket/base
|
|
(provide (all-defined-out))
|
|
(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)
|
|
(define metaschema-module-source
|
|
(schema->module-stx
|
|
'gen-schema
|
|
(parse-Schema
|
|
(with-input-from-file "../../../../schema/schema.bin" read-preserve))))
|
|
(if #t
|
|
(with-output-to-file "gen/schema.rkt" #:exists 'replace
|
|
(lambda () (pretty-write metaschema-module-source)))
|
|
(pretty-write metaschema-module-source)))
|